diff options
| author | Ian Lance Taylor <iant@golang.org> | 2021-10-27 08:47:25 -0700 |
|---|---|---|
| committer | Ian Lance Taylor <iant@golang.org> | 2021-10-27 08:47:25 -0700 |
| commit | a6d3012b274f38b20e2a57162106f625746af6c6 (patch) | |
| tree | 09ff8b13eb8ff7594c27dc8812efbf696dc97484 /gcc/testsuite | |
| parent | cd2fd5facb5e1882d3f338ed456ae9536f7c0593 (diff) | |
| parent | 99b1021d21e5812ed01221d8fca8e8a32488a934 (diff) | |
| download | gcc-a6d3012b274f38b20e2a57162106f625746af6c6.zip gcc-a6d3012b274f38b20e2a57162106f625746af6c6.tar.gz gcc-a6d3012b274f38b20e2a57162106f625746af6c6.tar.bz2 | |
Merge from trunk revision 99b1021d21e5812ed01221d8fca8e8a32488a934.
Diffstat (limited to 'gcc/testsuite')
453 files changed, 23691 insertions, 1013 deletions
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 1cc6add..d16e500 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,1182 @@ +2021-10-26 Martin Sebor <msebor@redhat.com> + + PR tree-optimization/102238 + PR tree-optimization/102919 + * gcc.dg/tree-ssa/builtin-sprintf-warn-23.c: Remove warnings. + * gcc.dg/Wrestrict-23.c: New test. + +2021-10-26 Martin Sebor <msebor@redhat.com> + + * gcc.dg/Wstringop-overflow-22.c: Correct typos. + * gcc.dg/Wstringop-overflow-81.c: New test. + +2021-10-26 Martin Sebor <msebor@redhat.com> + + PR middle-end/102453 + * gcc.dg/Warray-bounds-90.c: New test. + * gcc.dg/Wstringop-overflow-77.c: New test. + * gcc.dg/Wstringop-overflow-78.c: New test. + * gcc.dg/Wstringop-overflow-79.c: New test. + * gcc.dg/Wstringop-overflow-80.c: New test. + * c-c++-common/gomp/atomic-4.c: Avoid an out-of-bounds access. + +2021-10-26 Harald Anlauf <anlauf@gmx.de> + + PR fortran/86551 + * gfortran.dg/pr86551.f90: New test to verify that PR86551 remains + fixed. + +2021-10-26 Harald Anlauf <anlauf@gmx.de> + + PR fortran/102956 + * gfortran.dg/pdt_32.f03: New test. + +2021-10-26 Vladimir N. Makarov <vmakarov@redhat.com> + + PR rtl-optimization/102842 + * g++.target/arm/pr102842.C: New test. + +2021-10-26 Harald Anlauf <anlauf@gmx.de> + + PR fortran/102917 + * gfortran.dg/pdt_4.f03: Adjust testcase. + +2021-10-26 Harald Anlauf <anlauf@gmx.de> + + PR fortran/102816 + * gfortran.dg/pr102816.f90: New test. + +2021-10-26 Paul A. Clarke <pc@us.ibm.com> + + * gcc.target/powerpc/pr78102.c: Fix dg directives to require Power8 + vector support. Also, add -DNO_WARN_X86_INTRINSICS. + +2021-10-26 Marek Polacek <polacek@redhat.com> + + PR c++/102617 + * g++.dg/cpp23/init-stmt1.C: New test. + * g++.dg/cpp23/init-stmt2.C: New test. + +2021-10-26 Sandra Loosemore <sandra@codesourcery.com> + + PR testsuite/102910 + * gfortran.dg/c-interop/cf-descriptor-5-c.c: Use a static buffer + instead of alloca. + +2021-10-26 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> + + PR testsuite/102834 + * gcc.target/i386/avx512f-pr96891-3.c: Add -mstv -mno-stackrealign + to dg-options. + +2021-10-26 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> + + PR testsuite/102835 + * gcc.target/i386/avx512fp16-trunchf.c: Allow for %esp instead of + %ebp. + +2021-10-26 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> + + PR testsuite/102836 + * gcc.target/i386/pieces-memset-1.c: Add -mno-stackrealign to + dg-options. + * gcc.target/i386/pieces-memset-4.c: Likewise. + * gcc.target/i386/pieces-memset-7.c: Likewise. + * gcc.target/i386/pieces-memset-8.c: Likewise. + * gcc.target/i386/pieces-memset-41.c: Likewise. + * gcc.target/i386/pr90773-1.c: Likewise. + +2021-10-26 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> + + * gcc.target/i386/pr100704-1.c: Add -fomit-frame-pointer to + dg-options. + * gcc.target/i386/pr100704-2.c: Likewise. + +2021-10-26 Kewen Lin <linkw@linux.ibm.com> + + * gcc.dg/pr102897.c: New test. + +2021-10-26 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/102885 + * gfortran.dg/lto/bind-c-char_0.f90: New test. + +2021-10-26 Roger Sayle <roger@nextmovesoftware.com> + + * gcc.target/i386/sse2-v1ti-shift.c: New test case. + +2021-10-26 Aldy Hernandez <aldyh@redhat.com> + + PR testsuite/102857 + * gcc.dg/tree-ssa/ssa-dom-thread-7.c: Add -fdump-tree-vrp2-stats. + Tweak for aarch64. + +2021-10-26 Aldy Hernandez <aldyh@redhat.com> + + * gcc.dg/tree-ssa/pr21090.c: Adjust for threading. + * gcc.dg/tree-ssa/ssa-thread-12.c: Removed. + +2021-10-26 Aldy Hernandez <aldyh@redhat.com> + + * gcc.dg/graphite/scop-dsyr2k-2.c: Adjust for jump threading changes. + * gcc.dg/graphite/scop-dsyr2k.c: Same. + * gcc.dg/graphite/scop-dsyrk-2.c: Same. + * gcc.dg/graphite/scop-dsyrk.c: Same. + * gcc.dg/tree-ssa/pr20701.c: Same. + * gcc.dg/tree-ssa/pr20702.c: Same. + * gcc.dg/tree-ssa/pr21086.c: Same. + * gcc.dg/tree-ssa/pr25382.c: Same. + * gcc.dg/tree-ssa/pr58480.c: Same. + * gcc.dg/tree-ssa/ssa-vrp-thread-1.c: Same. + * gcc.dg/tree-ssa/vrp08.c: Same. + * gcc.dg/tree-ssa/vrp55.c: Same. + * gcc.dg/tree-ssa/ssa-dom-thread-7.c: Same. + * gcc.dg/tree-ssa/ssa-dom-thread-4.c: Removed. + * gcc.dg/tree-ssa/ssa-thread-11.c: Removed. + * gcc.dg/uninit-pr89230-1.c: xfail. + * gcc.dg/tree-ssa/ssa-thread-backedge.c: New file. + +2021-10-25 Andrew MacLeod <amacleod@redhat.com> + + * gcc.dg/tree-ssa/vrp98.c: Disable evrp for vrp1 test. + * gcc.dg/tree-ssa/vrp98-1.c: New. Test for folding in evrp. + +2021-10-25 Roger Sayle <roger@nextmovesoftware.com> + + * gcc.target/bfin/ssashift-1.c: New test case. + +2021-10-25 Tamar Christina <tamar.christina@arm.com> + + PR target/102907 + * gcc.target/aarch64/shrn-combine-1.c: Disable SVE. + * gcc.target/aarch64/shrn-combine-2.c: Likewise. + * gcc.target/aarch64/shrn-combine-3.c: Likewise. + * gcc.target/aarch64/shrn-combine-4.c: Likewise. + * gcc.target/aarch64/shrn-combine-5.c: Likewise. + * gcc.target/aarch64/shrn-combine-6.c: Likewise. + * gcc.target/aarch64/shrn-combine-7.c: Likewise. + +2021-10-25 Jim Wilson <jimw@sifive.com> + Kito Cheng <kito.cheng@sifive.com> + Jia-Wei Chen <jiawei@iscas.ac.cn> + Shi-Hua Liao <shihua@iscas.ac.cn> + + * gcc.target/riscv/zba-slliuw.c: Apply zbs to this testcase. + * gcc.target/riscv/zbs-bclr.c: New. + * gcc.target/riscv/zbs-bext.c: Ditto. + * gcc.target/riscv/zbs-binv.c: Ditto. + * gcc.target/riscv/zbs-bset.c: Ditto. + +2021-10-25 Jim Wilson <jimw@sifive.com> + + * gcc.target/riscv/zbb-li-rotr.c: New. + +2021-10-25 Jim Wilson <jimw@sifive.com> + Kito Cheng <kito.cheng@sifive.com> + Jia-Wei Chen <jiawei@iscas.ac.cn> + + * gcc.target/riscv/zbb-andn-orn-xnor-01.c: New. + * gcc.target/riscv/zbb-andn-orn-xnor-02.c: Ditto. + * gcc.target/riscv/zbb-min-max.c: Ditto. + * gcc.target/riscv/zbb-rol-ror-01.c: Ditto. + * gcc.target/riscv/zbb-rol-ror-02.c: Ditto. + * gcc.target/riscv/zbb-rol-ror-03.c: Ditto. + * gcc.target/riscv/zbbw.c: Ditto. + +2021-10-25 Jim Wilson <jimw@sifive.com> + Kito Cheng <kito.cheng@sifive.com> + Jia-Wei Chen <jiawei@iscas.ac.cn> + + * gcc.target/riscv/zba-adduw.c: New. + * gcc.target/riscv/zba-shNadd-01.c: Ditto. + * gcc.target/riscv/zba-shNadd-02.c: Ditto. + * gcc.target/riscv/zba-shNadd-03.c: Ditto. + * gcc.target/riscv/zba-slliuw.c: Ditto. + * gcc.target/riscv/zba-zextw.c: Ditto. + +2021-10-25 liuhongt <hongtao.liu@intel.com> + + PR target/102464 + * gcc.target/i386/pr102464-sqrtph.c: New test. + * gcc.target/i386/pr102464-sqrtsh.c: New test. + +2021-10-25 Richard Biener <rguenther@suse.de> + + PR tree-optimization/102920 + * gcc.dg/torture/pr102920.c: New testcase. + +2021-10-25 konglin1 <lingling.kong@intel.com> + + * gcc.target/i386/avx512fp16-complex-fma.c: New test. + +2021-10-24 Roger Sayle <roger@nextmovesoftware.com> + + * gcc.target/bfin/20090914-3.c: Tweak test case. + +2021-10-23 H.J. Lu <hjl.tools@gmail.com> + + PR fortran/9262 + * gfortran.dg/bind-c-intent-out-2.f90: Moved to ... + * gfortran.dg/ubsan/bind-c-intent-out-2.f90 + +2021-10-23 Roger Sayle <roger@nextmovesoftware.com> + + * gcc.target/i386/sse2-v1ti-logic.c: New test case. + * gcc.target/i386/sse2-v1ti-logic-2.c: New test case. + +2021-10-23 José Rui Faustino de Sousa <jrfsousa@gmail.com> + Sandra Loosemore <sandra@codesourcery.com> + + PR fortran/95196 + * gfortran.dg/PR95196.f90: New. + +2021-10-22 Tobias Burnus <tobias@codesourcery.com> + + * gfortran.dg/associate_3.f03: Replace dg-excess-errors by + other dg-* to change XFAIL to PASS. + * gfortran.dg/binding_label_tests_4.f03: Likewise. + * gfortran.dg/block_4.f08: Likewise. + * gfortran.dg/charlen_04.f90: Likewise. + * gfortran.dg/charlen_05.f90: Likewise. + * gfortran.dg/charlen_06.f90: Likewise. + * gfortran.dg/charlen_13.f90: Likewise. + * gfortran.dg/coarray_9.f90: Likewise. + * gfortran.dg/coarray_collectives_3.f90: Likewise. + * gfortran.dg/data_invalid.f90: Likewise. + * gfortran.dg/do_4.f: Likewise. + * gfortran.dg/dollar_sym_1.f90: Likewise. + * gfortran.dg/dollar_sym_3.f: Likewise. + * gfortran.dg/fmt_tab_1.f90: Likewise. + * gfortran.dg/fmt_tab_2.f90: Likewise. + * gfortran.dg/forall_16.f90: Likewise. + * gfortran.dg/g77/970125-0.f: Likewise. + * gfortran.dg/gomp/unexpected-end.f90: Likewise. + * gfortran.dg/interface_operator_1.f90: Likewise. + * gfortran.dg/interface_operator_2.f90: Likewise. + * gfortran.dg/line_length_4.f90: Likewise. + * gfortran.dg/line_length_5.f90: Likewise. + * gfortran.dg/line_length_6.f90: Likewise. + * gfortran.dg/line_length_8.f90: Likewise. + * gfortran.dg/line_length_9.f90: Likewise. + * gfortran.dg/pr65045.f90: Likewise. + * gfortran.dg/pr69497.f90: Likewise. + * gfortran.dg/submodule_21.f08: Likewise. + * gfortran.dg/tab_continuation.f: Likewise. + * gfortran.dg/typebound_proc_2.f90: Likewise. + * gfortran.dg/warnings_are_errors_1.f90: Likewise. + +2021-10-22 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/92621 + * gfortran.dg/bind-c-intent-out-2.f90: New test. + +2021-10-22 José Rui Faustino de Sousa <jrfsousa@gmail.com> + Sandra Loosemore <sandra@codesourcery.com> + + PR fortran/94289 + * gfortran.dg/PR94289.f90: New. + +2021-10-22 José Rui Faustino de Sousa <jrfsousa@gmail.com> + Sandra Loosemore <sandra@codesourcery.com> + + PR fortran/100906 + * gfortran.dg/PR100906.f90: New. + * gfortran.dg/PR100906.c: New. + +2021-10-22 Richard Biener <rguenther@suse.de> + + PR tree-optimization/102893 + * gcc.dg/tree-ssa/ssa-dce-9.c: New testcase. + +2021-10-22 Richard Biener <rguenther@suse.de> + + PR bootstrap/102681 + * gcc.dg/tree-ssa/ssa-fre-97.c: New testcase. + * gcc.dg/ubsan/pr81981.c: XFAIL one case. + +2021-10-21 Uroš Bizjak <ubizjak@gmail.com> + + PR testsuite/102840 + * gcc.target/i386/pr22076.c: Adjust to avoid compile time optimization. + +2021-10-21 Hongyu Wang <hongyu.wang@intel.com> + + * gcc.target/i386/avx512fp16-13.c: Adjust scan-assembler for + xmm/ymm load/store. + +2021-10-21 Martin Liska <mliska@suse.cz> + + PR debug/102585 + PR bootstrap/102766 + * gcc.dg/pr102585.c: New test. + +2021-10-21 Martin Jambor <mjambor@suse.cz> + + PR tree-optimization/102505 + * g++.dg/torture/pr102505.C: New test. + +2021-10-21 Jakub Jelinek <jakub@redhat.com> + + * gfortran.dg/gomp/strictly-structured-block-1.f90: Use call do_work + instead of x = x + 1 in places where the latter could be a data race. + * gfortran.dg/gomp/strictly-structured-block-2.f90: Likewise. + * gfortran.dg/gomp/strictly-structured-block-3.f90: Likewise. + +2021-10-21 Hongyu Wang <hongyu.wang@intel.com> + + PR target/102812 + * gcc.target/i386/pr102812.c: New test. + +2021-10-21 Jakub Jelinek <jakub@redhat.com> + + PR middle-end/64888 + * c-c++-common/ubsan/pr64888.c: New test. + +2021-10-21 Andrew Pinski <apinski@marvell.com> + + * gcc.dg/pr36902.c: Move buf to be a non-static variable. + +2021-10-21 Richard Biener <rguenther@suse.de> + + PR testsuite/102861 + * gcc.dg/vect/bb-slp-16.c: Revert previous change, scan + the vect dump instead. + +2021-10-21 Chung-Lin Tang <cltang@codesourcery.com> + + * gfortran.dg/gomp/cancel-1.f90: Adjust testcase. + * gfortran.dg/gomp/nesting-3.f90: Adjust testcase. + * gfortran.dg/gomp/strictly-structured-block-1.f90: New test. + * gfortran.dg/gomp/strictly-structured-block-2.f90: New test. + * gfortran.dg/gomp/strictly-structured-block-3.f90: New test. + +2021-10-21 Sandra Loosemore <sandra@codesourcery.com> + + PR fortran/94070 + * gfortran.dg/c-interop/shape-bindc.f90: New test. + * gfortran.dg/c-interop/shape-poly.f90: New test. + * gfortran.dg/c-interop/size-bindc.f90: New test. + * gfortran.dg/c-interop/size-poly.f90: New test. + * gfortran.dg/c-interop/ubound-bindc.f90: New test. + * gfortran.dg/c-interop/ubound-poly.f90: New test. + +2021-10-20 Tamar Christina <tamar.christina@arm.com> + + * gcc.target/aarch64/mvn-cmeq0-1.c: New test. + +2021-10-20 Tamar Christina <tamar.christina@arm.com> + + * gcc.target/aarch64/narrow_high_combine.c: Update case. + * gcc.target/aarch64/xtn-combine-1.c: New test. + * gcc.target/aarch64/xtn-combine-2.c: New test. + * gcc.target/aarch64/xtn-combine-3.c: New test. + * gcc.target/aarch64/xtn-combine-4.c: New test. + * gcc.target/aarch64/xtn-combine-5.c: New test. + * gcc.target/aarch64/xtn-combine-6.c: New test. + +2021-10-20 Tamar Christina <tamar.christina@arm.com> + + * gcc.target/aarch64/shl-combine-2.c: New test. + * gcc.target/aarch64/shl-combine-3.c: New test. + * gcc.target/aarch64/shl-combine-4.c: New test. + * gcc.target/aarch64/shl-combine-5.c: New test. + +2021-10-20 Tamar Christina <tamar.christina@arm.com> + + * gcc.target/aarch64/shrn-combine-10.c: New test. + * gcc.target/aarch64/shrn-combine-5.c: New test. + * gcc.target/aarch64/shrn-combine-6.c: New test. + * gcc.target/aarch64/shrn-combine-7.c: New test. + * gcc.target/aarch64/shrn-combine-8.c: New test. + * gcc.target/aarch64/shrn-combine-9.c: New test. + +2021-10-20 Tamar Christina <tamar.christina@arm.com> + + * gcc.target/aarch64/shrn-combine-1.c: New test. + * gcc.target/aarch64/shrn-combine-2.c: New test. + * gcc.target/aarch64/shrn-combine-3.c: New test. + * gcc.target/aarch64/shrn-combine-4.c: New test. + +2021-10-20 Chung-Lin Tang <cltang@codesourcery.com> + + * gfortran.dg/gomp/reduction4.f90: Adjust omp target in_reduction' scan + pattern. + +2021-10-20 Martin Liska <mliska@suse.cz> + + Revert: + 2021-10-20 Martin Liska <mliska@suse.cz> + + PR target/102374 + * gcc.target/i386/pr102374.c: New test. + +2021-10-20 Martin Liska <mliska@suse.cz> + + Revert: + 2021-10-20 Martin Liska <mliska@suse.cz> + + PR target/102375 + * gcc.target/aarch64/pr102375.c: New test. + +2021-10-20 Wilco Dijkstra <wdijkstr@arm.com> + + PR target/100966 + * gcc.target/aarch64/frint.x: Add roundeven tests. + * gcc.target/aarch64/frint_double.c: Likewise. + * gcc.target/aarch64/frint_float.c: Likewise. + +2021-10-20 Andre Simoes Dias Vieira <andre.simoesdiasvieira@arm.com> + + * gcc.target/aarch64/fmla_intrinsic_1.c: prevent over optimization. + * gcc.target/aarch64/fmls_intrinsic_1.c: Likewise. + * gcc.target/aarch64/fmul_intrinsic_1.c: Likewise. + * gcc.target/aarch64/mla_intrinsic_1.c: Likewise. + * gcc.target/aarch64/mls_intrinsic_1.c: Likewise. + * gcc.target/aarch64/mul_intrinsic_1.c: Likewise. + * gcc.target/aarch64/simd/vmul_elem_1.c: Likewise. + * gcc.target/aarch64/vclz.c: Likewise. + * gcc.target/aarch64/vneg_s.c: Likewise. + +2021-10-20 Andre Simoes Dias Vieira <andre.simoesdiasvieira@arm.com> + + * gcc.target/aarch64/merge_trunc1.c: New test. + +2021-10-20 Eric Botcazou <ebotcazou@adacore.com> + + * gcc.dg/pr102764.c: New test. + +2021-10-20 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/102815 + * gfortran.dg/bind-c-contiguous-5.c (do_call, reset_var): Handle + big andian. + +2021-10-20 Jakub Jelinek <jakub@redhat.com> + + PR c++/102642 + * g++.dg/tls/pr102642.C: New test. + +2021-10-20 Aldy Hernandez <aldyh@redhat.com> + Richard Biener <rguenther@suse.de> + + * gcc.dg/Warray-bounds-87.c: Remove xfail. + * gcc.dg/analyzer/pr94851-2.c: Remove xfail. + * gcc.dg/graphite/pr69728.c: Remove xfail. + * gcc.dg/graphite/scop-dsyr2k.c: Remove xfail. + * gcc.dg/graphite/scop-dsyrk.c: Remove xfail. + * gcc.dg/shrink-wrap-loop.c: Remove xfail. + * gcc.dg/loop-8.c: Adjust for new threading restrictions. + * gcc.dg/tree-ssa/ifc-20040816-1.c: Same. + * gcc.dg/tree-ssa/pr21559.c: Same. + * gcc.dg/tree-ssa/pr59597.c: Same. + * gcc.dg/tree-ssa/pr71437.c: Same. + * gcc.dg/tree-ssa/pr77445-2.c: Same. + * gcc.dg/tree-ssa/ssa-dom-thread-4.c: Same. + * gcc.dg/tree-ssa/ssa-dom-thread-7.c: Same. + * gcc.dg/vect/bb-slp-16.c: Same. + * gcc.dg/tree-ssa/ssa-dom-thread-6.c: Remove. + * gcc.dg/tree-ssa/ssa-dom-thread-18.c: Remove. + * gcc.dg/tree-ssa/ssa-dom-thread-2a.c: Remove. + * gcc.dg/tree-ssa/ssa-thread-invalid.c: New test. + +2021-10-20 Jeff Law <jeffreyalaw@gmail.com> + + * gcc.dg/plugin/gil-1.c: Add dg-require-effective-target marker. + +2021-10-20 Hongtao Liu <hongtao.liu@intel.com> + Kewen Lin <linkw@linux.ibm.com> + + PR middle-end/102722 + PR middle-end/102697 + PR middle-end/102462 + PR middle-end/102706 + PR middle-end/102744 + * c-c++-common/Wstringop-overflow-2.c: Adjust testcase with new + xfail/target selector. + * gcc.dg/Warray-bounds-51.c: Ditto. + * gcc.dg/Warray-parameter-3.c: Ditto. + * gcc.dg/Wstringop-overflow-14.c: Ditto. + * gcc.dg/Wstringop-overflow-21.c: Ditto. + * gcc.dg/Wstringop-overflow-68.c: Ditto. + * gcc.dg/Wstringop-overflow-76.c: Ditto. + * gcc.dg/Warray-bounds-48.c: Ditto. + * gcc.dg/Wzero-length-array-bounds-2.c: Ditto. + * lib/target-supports.exp (check_vect_slp_aligned_store_usage): + New function. + (check_effective_target_vect_slp_v2qi_store): Ditto. + (check_effective_target_vect_slp_v4qi_store): Ditto. + (check_effective_target_vect_slp_v8qi_store): Ditto. + (check_effective_target_vect_slp_v16qi_store): Ditto. + (check_effective_target_vect_slp_v2hi_store): Ditto. + (check_effective_target_vect_slp_v4hi_store): Ditto. + (check_effective_target_vect_slp_v2si_store): Ditto. + (check_effective_target_vect_slp_v4si_store): Ditto. + * c-c++-common/Wstringop-overflow-2-novec.c: New test. + * gcc.dg/Warray-bounds-51-novec.c: New test. + * gcc.dg/Warray-bounds-48-novec.c: New test. + * gcc.dg/Warray-parameter-3-novec.c: New test. + * gcc.dg/Wstringop-overflow-14-novec.c: New test. + * gcc.dg/Wstringop-overflow-21-novec.c: New test. + * gcc.dg/Wstringop-overflow-76-novec.c: New test. + * gcc.dg/Wzero-length-array-bounds-2-novec.c: New test. + +2021-10-19 Paul A. Clarke <pc@us.ibm.com> + + * gcc.target/powerpc/sse4_2-pcmpgtq.c: Tighten dg constraints + to minimally Power8. + +2021-10-19 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/92482 + * gfortran.dg/bind-c-char-descr.f90: Remove xfail; extend a bit. + +2021-10-19 Martin Liska <mliska@suse.cz> + + PR target/102375 + * gcc.target/aarch64/pr102375.c: New test. + +2021-10-19 Richard Biener <rguenther@suse.de> + + PR tree-optimization/102827 + * gcc.dg/pr102827.c: New testcase. + +2021-10-19 Xionghu Luo <luoxhu@linux.ibm.com> + + * gcc.target/powerpc/builtins-1.c: Update instruction counts. + +2021-10-19 Haochen Gui <guihaoc@gcc.gnu.org> + + * gcc.target/powerpc/p10_vec_xl_sext.c: New test. + +2021-10-19 prathamesh.kulkarni <prathamesh.kulkarni@linaro.org> + + PR target/93183 + * gcc.target/aarch64/sve/pr93183.c: Remove -mcpu=generic+sve from dg-options. + +2021-10-19 Jakub Jelinek <jakub@redhat.com> + + PR c++/102786 + * g++.dg/cpp2a/constexpr-virtual19.C: New test. + +2021-10-19 Martin Liska <mliska@suse.cz> + + PR target/102374 + * gcc.target/i386/pr102374.c: New test. + +2021-10-19 dianhong xu <dianhong.xu@intel.com> + + * gcc.target/i386/avx512fp16-set1-pch-1a.c: New test. + * gcc.target/i386/avx512fp16-set1-pch-1b.c: New test. + * gcc.target/i386/avx512fp16vl-set1-pch-1a.c: New test. + * gcc.target/i386/avx512fp16vl-set1-pch-1b.c: New test. + +2021-10-18 Andrew MacLeod <amacleod@redhat.com> + + PR tree-optimization/102796 + * g++.dg/pr102796.C: New. + +2021-10-18 Kwok Cheung Yeung <kcy@codesourcery.com> + + * gfortran.dg/gomp/declare-variant-15.f90 (variant2, base2, test2): + Add tests. + * gfortran.dg/gomp/declare-variant-16.f90 (base2, variant2, test2): + Add tests. + +2021-10-18 Uroš Bizjak <ubizjak@gmail.com> + + PR target/102761 + * gcc.target/i386/pr102761.c: New test. + +2021-10-18 Jason Merrill <jason@redhat.com> + + * g++.dg/template/crash90.C: Check location of pedwarn. + +2021-10-18 H.J. Lu <hjl.tools@gmail.com> + + * gcc.target/i386/387-12.c (dg-do compile): Require ia32. + (dg-options): Remove -m32. + +2021-10-18 Roger Sayle <roger@nextmovesoftware.com> + + * gcc.target/i386/387-12.c: Add explicit -m32 option. + +2021-10-18 Roger Sayle <roger@nextmovesoftware.com> + + * gcc.target/bfin/ones.c: New test case. + * gcc.target/bfin/parity.c: New test case. + * gcc.target/bfin/popcount.c: New test case. + +2021-10-18 Richard Biener <rguenther@suse.de> + + PR tree-optimization/102788 + * g++.dg/vect/pr102788.cc: New testcase. + +2021-10-18 Roger Sayle <roger@nextmovesoftware.com> + + * gcc.target/bfin/ssabs.c: New test case. + * gcc.target/bfin/ssneg.c: New test case. + +2021-10-18 prathamesh.kulkarni <prathamesh.kulkarni@linaro.org> + + PR target/93183 + * gcc.target/aarch64/sve/cond_unary_4.c: Adjust. + * gcc.target/aarch64/sve/pr93183.c: New test. + +2021-10-18 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/102086 + PR fortran/92189 + PR fortran/92621 + PR fortran/101308 + PR fortran/101309 + PR fortran/101635 + PR fortran/92482 + * gfortran.dg/ISO_Fortran_binding_4.f90: Extend testcase. + * gfortran.dg/PR100914.f90: Remove xfail. + * gfortran.dg/PR100915.c: Expect CFI_type_cfunptr. + * gfortran.dg/PR100915.f90: Handle CFI_type_cfunptr != CFI_type_cptr. + * gfortran.dg/PR93963.f90: Extend select-rank tests. + * gfortran.dg/bind-c-intent-out.f90: Change to dg-do run, + update scan-dump. + * gfortran.dg/bind_c_array_params_2.f90: Update/extend scan-dump. + * gfortran.dg/bind_c_char_10.f90: Update scan-dump. + * gfortran.dg/bind_c_char_8.f90: Remove dg-error "sorry". + * gfortran.dg/c-interop/allocatable-dummy.f90: Remove xfail. + * gfortran.dg/c-interop/c1255-1.f90: Likewise. + * gfortran.dg/c-interop/c407c-1.f90: Update dg-error. + * gfortran.dg/c-interop/cf-descriptor-5.f90: Remove xfail. + * gfortran.dg/c-interop/cf-out-descriptor-3.f90: Likewise. + * gfortran.dg/c-interop/cf-out-descriptor-4.f90: Likewise. + * gfortran.dg/c-interop/cf-out-descriptor-5.f90: Likewise. + * gfortran.dg/c-interop/contiguous-2.f90: Likewise. + * gfortran.dg/c-interop/contiguous-3.f90: Likewise. + * gfortran.dg/c-interop/deferred-character-1.f90: Likewise. + * gfortran.dg/c-interop/deferred-character-2.f90: Likewise. + * gfortran.dg/c-interop/fc-descriptor-3.f90: Likewise. + * gfortran.dg/c-interop/fc-descriptor-5.f90: Likewise. + * gfortran.dg/c-interop/fc-descriptor-6.f90: Likewise. + * gfortran.dg/c-interop/fc-out-descriptor-3.f90: Likewise. + * gfortran.dg/c-interop/fc-out-descriptor-4.f90: Likewise. + * gfortran.dg/c-interop/fc-out-descriptor-5.f90: Likewise. + * gfortran.dg/c-interop/fc-out-descriptor-6.f90: Likewise. + * gfortran.dg/c-interop/ff-descriptor-5.f90: Likewise. + * gfortran.dg/c-interop/ff-descriptor-6.f90: Likewise. + * gfortran.dg/c-interop/fc-descriptor-7.f90: Remove xfail + extend. + * gfortran.dg/c-interop/fc-descriptor-7-c.c: Update for changes. + * gfortran.dg/c-interop/shape.f90: Add implicit none. + * gfortran.dg/c-interop/typecodes-array-char-c.c: Add kind=4 char. + * gfortran.dg/c-interop/typecodes-array-char.f90: Likewise. + * gfortran.dg/c-interop/typecodes-array-float128.f90: Remove xfail. + * gfortran.dg/c-interop/typecodes-scalar-basic.f90: Likewise. + * gfortran.dg/c-interop/typecodes-scalar-float128.f90: Likewise. + * gfortran.dg/c-interop/typecodes-scalar-int128.f90: Likewise. + * gfortran.dg/c-interop/typecodes-scalar-longdouble.f90: Likewise. + * gfortran.dg/iso_c_binding_char_1.f90: Remove dg-error "sorry". + * gfortran.dg/pr93792.f90: Turn XFAIL into PASS. + * gfortran.dg/ISO_Fortran_binding_19.f90: New test. + * gfortran.dg/assumed_type_12.f90: New test. + * gfortran.dg/assumed_type_13.c: New test. + * gfortran.dg/assumed_type_13.f90: New test. + * gfortran.dg/bind-c-char-descr.f90: New test. + * gfortran.dg/bind-c-contiguous-1.c: New test. + * gfortran.dg/bind-c-contiguous-1.f90: New test. + * gfortran.dg/bind-c-contiguous-2.f90: New test. + * gfortran.dg/bind-c-contiguous-3.c: New test. + * gfortran.dg/bind-c-contiguous-3.f90: New test. + * gfortran.dg/bind-c-contiguous-4.c: New test. + * gfortran.dg/bind-c-contiguous-4.f90: New test. + * gfortran.dg/bind-c-contiguous-5.c: New test. + * gfortran.dg/bind-c-contiguous-5.f90: New test. + +2021-10-18 Richard Biener <rguenther@suse.de> + + PR tree-optimization/102798 + * gcc.dg/pr102798.c: New testcase. + +2021-10-18 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/102745 + * gfortran.dg/class_72.f90: New. + +2021-10-15 Jason Merrill <jason@redhat.com> + + PR c++/51851 + PR c++/101402 + PR c++/102033 + PR c++/102034 + PR c++/102039 + PR c++/102044 + * g++.dg/template/fnspec2.C: New test. + * g++.dg/template/parm-cv1.C: New test. + * g++.dg/template/parm-cv2.C: New test. + * g++.dg/template/parm-cv3.C: New test. + +2021-10-15 Harald Anlauf <anlauf@gmx.de> + Tobias Burnus <tobias@codesourcery.com> + + PR fortran/102685 + * gfortran.dg/derived_constructor_char_1.f90: Fix invalid code. + * gfortran.dg/pr70931.f90: Likewise. + * gfortran.dg/transfer_simplify_2.f90: Likewise. + * gfortran.dg/pr102685.f90: New test. + +2021-10-15 Aldy Hernandez <aldyh@redhat.com> + + * gcc.dg/tree-ssa/pr102736.c: Make sign explicit. + +2021-10-15 Richard Biener <rguenther@suse.de> + + * lib/prune.exp: Prune STABS obsoletion message. + +2021-10-15 Richard Biener <rguenther@suse.de> + + PR c/102763 + * gcc.dg/gimplefe-error-12.c: New testcase. + +2021-10-15 Richard Biener <rguenther@suse.de> + + PR ipa/102762 + * gcc.dg/torture/pr102762.c: New testcase. + +2021-10-15 Hongyu Wang <hongyu.wang@intel.com> + + * gcc.target/i386/avx512fp16-builtin_shuffle-1.c: New test. + * gcc.target/i386/avx512fp16-pr101846.c: Ditto. + * gcc.target/i386/avx512fp16-pr94680.c: Ditto. + +2021-10-15 Hongyu Wang <hongyu.wang@intel.com> + + * gcc.target/i386/avx512fp16-v4hf-concat.c: New test. + +2021-10-15 Hongyu Wang <hongyu.wang@intel.com> + + * gcc.target/i386/avx512fp16-vfcmaddcph-1a.c: Add scan for + vblendmps. + * gcc.target/i386/avx512fp16-vfmaddcph-1a.c: Likewise. + * gcc.target/i386/avx512fp16vl-vfcmaddcph-1a.c: Likewise. + * gcc.target/i386/avx512fp16vl-vfmaddcph-1a.c: Likewise. + * gcc.target/i386/avx512fp16-vfmaddcsh-1a.c: Add -mno-avx512vl. + * gcc.target/i386/avx512fp16-vfcmaddcsh-1a.c: Likewise. + +2021-10-15 Jason Merrill <jason@redhat.com> + + * g++.dg/ext/vla22.C: Don't expect a narrowing error. + * g++.dg/cpp0x/constexpr-inst1.C: New test. + +2021-10-15 Andrew MacLeod <amacleod@redhat.com> + + * gcc.dg/pr102738.c: Add target int128. + +2021-10-14 Joseph Myers <joseph@codesourcery.com> + + * gcc.dg/format/c11-dfp-printf-1.c, + gcc.dg/format/c11-dfp-scanf-1.c, gcc.dg/format/c2x-dfp-printf-1.c, + gcc.dg/format/c2x-dfp-scanf-1.c: New tests. + +2021-10-14 Raphael Moreira Zinsly <rzinsly@linux.ibm.com> + + * gcc.target/powerpc/unwind-backchain.c: New test. + +2021-10-14 Harald Anlauf <anlauf@gmx.de> + + PR fortran/102717 + * gfortran.dg/reshape_shape_2.f90: New test. + +2021-10-14 Harald Anlauf <anlauf@gmx.de> + + PR fortran/102716 + * gfortran.dg/shape_10.f90: New test. + +2021-10-14 Andrew MacLeod <amacleod@redhat.com> + + PR tree-optimization/102738 + * gcc.dg/pr102738.c: New. + +2021-10-14 Kwok Cheung Yeung <kcy@codesourcery.com> + + * gfortran.dg/gomp/declare-variant-1.f90: New test. + * gfortran.dg/gomp/declare-variant-10.f90: New test. + * gfortran.dg/gomp/declare-variant-11.f90: New test. + * gfortran.dg/gomp/declare-variant-12.f90: New test. + * gfortran.dg/gomp/declare-variant-13.f90: New test. + * gfortran.dg/gomp/declare-variant-14.f90: New test. + * gfortran.dg/gomp/declare-variant-15.f90: New test. + * gfortran.dg/gomp/declare-variant-16.f90: New test. + * gfortran.dg/gomp/declare-variant-17.f90: New test. + * gfortran.dg/gomp/declare-variant-18.f90: New test. + * gfortran.dg/gomp/declare-variant-19.f90: New test. + * gfortran.dg/gomp/declare-variant-2.f90: New test. + * gfortran.dg/gomp/declare-variant-2a.f90: New test. + * gfortran.dg/gomp/declare-variant-3.f90: New test. + * gfortran.dg/gomp/declare-variant-4.f90: New test. + * gfortran.dg/gomp/declare-variant-5.f90: New test. + * gfortran.dg/gomp/declare-variant-6.f90: New test. + * gfortran.dg/gomp/declare-variant-7.f90: New test. + * gfortran.dg/gomp/declare-variant-8.f90: New test. + * gfortran.dg/gomp/declare-variant-9.f90: New test. + +2021-10-14 Jeff Law <jeffreyalaw@gmail.com> + + * gcc.target/mips/msa-insert-split.c: Turn off vectorizer. + +2021-10-14 Tamar Christina <tamar.christina@arm.com> + + * gcc.target/aarch64/sve/pred-cond-reduc.c: New test. + +2021-10-14 Jeff Law <jeffreyalaw@gmail.com> + + * gcc.dg/tree-ssa/predcom-3.c: Disable vectorizer. + +2021-10-14 Aldy Hernandez <aldyh@redhat.com> + + PR tree-optimization/102736 + * gcc.dg/tree-ssa/pr102736.c: New test. + +2021-10-14 Hongyu Wang <hongyu.wang@intel.com> + + * gcc.target/i386/avx-1.c: Add new mask3 builtins. + * gcc.target/i386/sse-13.c: Ditto. + * gcc.target/i386/sse-23.c: Ditto. + * gcc.target/i386/avx512fp16-vfcmaddcsh-1a.c: Add scanning for + mask/mask3 intrinsic. + * gcc.target/i386/avx512fp16-vfmaddcsh-1a.c: Ditto. + * gcc.target/i386/avx512fp16-vfcmaddcsh-1c.c: New test for + -mavx512vl. + * gcc.target/i386/avx512fp16-vfmaddcsh-1c.c: Ditto. + +2021-10-14 liuhongt <hongtao.liu@intel.com> + + * g++.dg/warn/Wuninitialized-13.C: Add -fno-tree-vectorize. + +2021-10-13 Martin Sebor <msebor@redhat.com> + + PR middle-end/102630 + * gcc.target/i386/addr-space-2.c: Add -Wall. + * gcc.target/i386/addr-space-3.c: New test. + +2021-10-13 Andre Vieira <andre.simoesdiasvieira@arm.com> + + * gcc.target/arm/mve/mve.exp: Make it test main directory. + * gcc.target/arm/mve/mve_load_memory_modes.c: New test. + * gcc.target/arm/mve/mve_store_memory_modes.c: New test. + +2021-10-13 Richard Biener <rguenther@suse.de> + + PR tree-optimization/102659 + * gcc.dg/torture/pr69760.c: Adjust the testcase. + * gcc.target/i386/avx2-vect-mask-store-move1.c: Expect to move + the conversions to unsigned as well. + +2021-10-13 Richard Biener <rguenther@suse.de> + + PR ipa/102714 + * gcc.dg/ipa/pr102714.c: New testcase. + +2021-10-13 Kewen Lin <linkw@linux.ibm.com> + + PR testsuite/102658 + * gcc.target/powerpc/dform-1.c: Adjust as vectorization enabled at O2. + * gcc.target/powerpc/dform-2.c: Likewise. + * gcc.target/powerpc/pr80510-2.c: Likewise. + +2021-10-12 Joseph Myers <joseph@codesourcery.com> + + * gcc.dg/format/c11-printf-1.c, gcc.dg/format/c11-scanf-1.c, + gcc.dg/format/c2x-printf-1.c, gcc.dg/format/c2x-scanf-1.c, + gcc.dg/format/ext-9.c, gcc.dg/format/ext-10.c: New tests. + +2021-10-12 Bill Schmidt <wschmidt@linux.ibm.com> + + PR target/101985 + * gcc.target/powerpc/pr101985-1.c: New. + * gcc.target/powerpc/pr101985-2.c: New. + +2021-10-12 Uroš Bizjak <ubizjak@gmail.com> + + PR target/85730 + PR target/82524 + * gcc.target/i386/pr85730.c: New test. + +2021-10-12 Richard Biener <rguenther@suse.de> + + PR tree-optimization/102696 + * g++.dg/vect/pr102696.cc: New testcase. + +2021-10-12 Richard Biener <rguenther@suse.de> + + PR tree-optimization/102572 + * g++.dg/vect/pr102572.cc: New testcase. + +2021-10-12 Tamar Christina <tamar.christina@arm.com> + + * gcc.target/aarch64/sve/pred-not-gen-1.c: New test. + * gcc.target/aarch64/sve/pred-not-gen-2.c: New test. + * gcc.target/aarch64/sve/pred-not-gen-3.c: New test. + * gcc.target/aarch64/sve/pred-not-gen-4.c: New test. + +2021-10-12 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/102541 + * gfortran.dg/assumed_rank_24.f90: New test. + +2021-10-12 Jakub Jelinek <jakub@redhat.com> + + * gcc.dg/gomp/simd-2.c: Remove option -fvect-cost-model=cheap. + * gcc.dg/gomp/simd-3.c: Likewise. + +2021-10-12 liuhongt <hongtao.liu@intel.com> + + * gcc.target/i386/pr102483.c: New test. + * gcc.target/i386/pr102483-2.c: New test. + +2021-10-12 Paul A. Clarke <pc@us.ibm.com> + + * gcc.target/powerpc/pr78102.c: Fix dg-require-effective-target. + * gcc.target/powerpc/sse4_1-packusdw.c: Likewise. + * gcc.target/powerpc/sse4_1-pmaxsb.c: Likewise. + * gcc.target/powerpc/sse4_1-pmaxsd.c: Likewise. + * gcc.target/powerpc/sse4_1-pmaxud.c: Likewise. + * gcc.target/powerpc/sse4_1-pmaxuw.c: Likewise. + * gcc.target/powerpc/sse4_1-pminsb.c: Likewise. + * gcc.target/powerpc/sse4_1-pminsd.c: Likewise. + * gcc.target/powerpc/sse4_1-pminud.c: Likewise. + * gcc.target/powerpc/sse4_1-pminuw.c: Likewise. + * gcc.target/powerpc/sse4_1-pmovsxbd.c: Likewise. + * gcc.target/powerpc/sse4_1-pmovsxbw.c: Likewise. + * gcc.target/powerpc/sse4_1-pmovsxwd.c: Likewise. + * gcc.target/powerpc/sse4_1-pmovzxbd.c: Likewise. + * gcc.target/powerpc/sse4_1-pmovzxbq.c: Likewise. + * gcc.target/powerpc/sse4_1-pmovzxbw.c: Likewise. + * gcc.target/powerpc/sse4_1-pmovzxdq.c: Likewise. + * gcc.target/powerpc/sse4_1-pmovzxwd.c: Likewise. + * gcc.target/powerpc/sse4_1-pmovzxwq.c: Likewise. + * gcc.target/powerpc/sse4_1-pmulld.c: Likewise. + * gcc.target/powerpc/sse4_2-pcmpgtq.c: Likewise. + * gcc.target/powerpc/sse4_1-phminposuw.c: Use correct + dg-require-effective-target. + +2021-10-12 Paul A. Clarke <pc@us.ibm.com> + + * gcc.target/powerpc/pr78102.c: Copy from gcc.target/i386, + adjust dg directives to suit. + * gcc.target/powerpc/sse4_1-packusdw.c: Same. + * gcc.target/powerpc/sse4_1-pcmpeqq.c: Same. + * gcc.target/powerpc/sse4_1-pmuldq.c: Same. + * gcc.target/powerpc/sse4_1-pmulld.c: Same. + * gcc.target/powerpc/sse4_2-pcmpgtq.c: Same. + * gcc.target/powerpc/sse4_2-check.h: Copy from gcc.target/i386, + tweak to suit. + +2021-10-12 Paul A. Clarke <pc@us.ibm.com> + + * gcc.target/powerpc/sse4_1-pmovsxbd.c: Copy from gcc.target/i386, + adjust dg directives to suit. + * gcc.target/powerpc/sse4_1-pmovsxbq.c: Same. + * gcc.target/powerpc/sse4_1-pmovsxbw.c: Same. + * gcc.target/powerpc/sse4_1-pmovsxdq.c: Same. + * gcc.target/powerpc/sse4_1-pmovsxwd.c: Same. + * gcc.target/powerpc/sse4_1-pmovsxwq.c: Same. + * gcc.target/powerpc/sse4_1-pmovzxbd.c: Same. + * gcc.target/powerpc/sse4_1-pmovzxbq.c: Same. + * gcc.target/powerpc/sse4_1-pmovzxbw.c: Same. + * gcc.target/powerpc/sse4_1-pmovzxdq.c: Same. + * gcc.target/powerpc/sse4_1-pmovzxwd.c: Same. + * gcc.target/powerpc/sse4_1-pmovzxwq.c: Same. + +2021-10-12 Paul A. Clarke <pc@us.ibm.com> + + * gcc.target/powerpc/sse4_1-pmaxsb.c: Copy from gcc.target/i386. + * gcc.target/powerpc/sse4_1-pmaxsd.c: Same. + * gcc.target/powerpc/sse4_1-pmaxud.c: Same. + * gcc.target/powerpc/sse4_1-pmaxuw.c: Same. + * gcc.target/powerpc/sse4_1-pminsb.c: Same. + * gcc.target/powerpc/sse4_1-pminsd.c: Same. + * gcc.target/powerpc/sse4_1-pminud.c: Same. + * gcc.target/powerpc/sse4_1-pminuw.c: Same. + +2021-10-11 Jan Hubicka <hubicka@ucw.cz> + + * gcc.dg/torture/ssa-pta-fn-1.c: Fix template; add noipa. + * gcc.dg/tree-ssa/pta-callused.c: Fix template. + +2021-10-11 Patrick Palka <ppalka@redhat.com> + + PR c++/102643 + * g++.dg/cpp2a/class-deduction-alias11.C: New test. + +2021-10-11 Richard Biener <rguenther@suse.de> + + PR middle-end/101480 + * g++.dg/torture/pr10148.C: New testcase. + +2021-10-11 Stefan Schulze Frielinghaus <stefansf@linux.ibm.com> + + * gcc.target/s390/rawmemchr-1.c: New test. + +2021-10-11 Stefan Schulze Frielinghaus <stefansf@linux.ibm.com> + + * gcc.dg/tree-ssa/ldist-rawmemchr-1.c: New test. + * gcc.dg/tree-ssa/ldist-rawmemchr-2.c: New test. + * gcc.dg/tree-ssa/ldist-strlen-1.c: New test. + * gcc.dg/tree-ssa/ldist-strlen-2.c: New test. + * gcc.dg/tree-ssa/ldist-strlen-3.c: New test. + +2021-10-11 Kito Cheng <kito.cheng@sifive.com> + + PR target/100316 + * gcc.c-torture/compile/pr100316.c: New. + +2021-10-11 liuhongt <hongtao.liu@intel.com> + + PR middle-end/102669 + * gnat.dg/unroll1.adb: Add -fno-tree-vectorize. + +2021-10-10 Harald Anlauf <anlauf@gmx.de> + + PR fortran/99348 + PR fortran/102521 + * gfortran.dg/parameter_array_init_8.f90: New test. + +2021-10-10 Andrew Pinski <apinski@marvell.com> + + PR tree-optimization/102622 + * gcc.c-torture/execute/bitfld-10.c: New test. + +2021-10-09 Harald Anlauf <anlauf@gmx.de> + + PR fortran/65454 + * gfortran.dg/interface_operator_3.f90: New test. + +2021-10-09 Kewen Lin <linkw@linux.ibm.com> + + * c-c++-common/Wstringop-overflow-2.c: Add missing comment. + * gcc.dg/Warray-bounds-51.c: Likewise. + * gcc.dg/Warray-parameter-3.c: Likewise. + * gcc.dg/Wstringop-overflow-14.c: Likewise. + * gcc.dg/Wstringop-overflow-21.c: Likewise. + * gcc.dg/Wstringop-overflow-76.c: Likewise. + +2021-10-09 liuhongt <hongtao.liu@intel.com> + + * g++.dg/tree-ssa/pr94403.C: Add -fno-tree-vectorize + * gcc.dg/optimize-bswapsi-5.c: Ditto. + * gcc.dg/optimize-bswapsi-6.c: Ditto. + * gcc.dg/Warray-bounds-51.c: Add additional option + -mtune=generic for target x86/i?86 + * gcc.dg/Wstringop-overflow-14.c: Ditto. + +2021-10-09 Jakub Jelinek <jakub@redhat.com> + + * c-c++-common/gomp/sections1.c (foo): Don't expect errors on + multiple statements in between section directive(s). Add testcases + for invalid no statements in between section directive(s). + * gcc.dg/gomp/sections-2.c (foo): Don't expect errors on + multiple statements in between section directive(s). + * g++.dg/gomp/sections-2.C (foo): Likewise. + * g++.dg/gomp/attrs-6.C (foo): Add testcases for multiple + statements in between section directive(s). + (bar): Add testcases for multiple statements in between scan + directive. + * g++.dg/gomp/attrs-7.C (bar): Adjust expected error recovery. + +2021-10-09 liuhongt <hongtao.liu@intel.com> + + * g++.target/i386/pr102639.C: New test. + +2021-10-08 Sandra Loosemore <sandra@codesourcery.com> + + PR fortran/54753 + * gfortran.dg/c-interop/c535c-1.f90: Rewrite and expand. + * gfortran.dg/c-interop/c535c-2.f90: Remove xfails. + * gfortran.dg/c-interop/c535c-3.f90: Likewise. + * gfortran.dg/c-interop/c535c-4.f90: Likewise. + * gfortran.dg/PR94110.f90: Extend to cover class types. + +2021-10-08 Vladimir N. Makarov <vmakarov@redhat.com> + + PR rtl-optimization/102627 + * gcc.target/i386/pr102627.c: New test. + +2021-10-08 Richard Sandiford <richard.sandiford@arm.com> + + * gcc.dg/pr102385.c: New test. + +2021-10-08 Jakub Jelinek <jakub@redhat.com> + + PR c++/102640 + * c-c++-common/gomp/pr102640.c: New test. + +2021-10-08 Roger Sayle <roger@nextmovesoftware.com> + + * gcc.target/i386/sse2-mmx-paddsb-2.c: Test for -128 or 128. + * gcc.target/i386/sse2-mmx-paddusb-2.c: Test for -1 or 255. + * gcc.target/i386/sse2-mmx-psubsb-2.c: Test for -128 or 128. + +2021-10-08 liuhongt <hongtao.liu@intel.com> + + * gcc.target/i386/pr102464.c: New test. + +2021-10-08 liuhongt <hongtao.liu@intel.com> + + * gcc.target/i386/mmx-reduce-op-1.c: New test. + * gcc.target/i386/mmx-reduce-op-2.c: New test. + +2021-10-08 liuhongt <hongtao.liu@intel.com> + + * c-c++-common/Wstringop-overflow-2.c: Adjust testcase. + * g++.dg/tree-ssa/pr81408.C: Ditto. + * g++.dg/warn/Wuninitialized-13.C: Ditto. + * gcc.dg/Warray-bounds-51.c: Ditto. + * gcc.dg/Warray-parameter-3.c: Ditto. + * gcc.dg/Wstringop-overflow-14.c: Ditto. + * gcc.dg/Wstringop-overflow-21.c: Ditto. + * gcc.dg/Wstringop-overflow-68.c: Ditto. + * gcc.dg/Wstringop-overflow-76.c: Ditto. + * gcc.dg/gomp/pr46032-2.c: Ditto. + * gcc.dg/gomp/pr46032-3.c: Ditto. + * gcc.dg/gomp/simd-2.c: Ditto. + * gcc.dg/gomp/simd-3.c: Ditto. + * gcc.dg/graphite/fuse-1.c: Ditto. + * gcc.dg/pr67089-6.c: Ditto. + * gcc.dg/pr82929-2.c: Ditto. + * gcc.dg/pr82929.c: Ditto. + * gcc.dg/store_merging_1.c: Ditto. + * gcc.dg/store_merging_11.c: Ditto. + * gcc.dg/store_merging_13.c: Ditto. + * gcc.dg/store_merging_15.c: Ditto. + * gcc.dg/store_merging_16.c: Ditto. + * gcc.dg/store_merging_19.c: Ditto. + * gcc.dg/store_merging_24.c: Ditto. + * gcc.dg/store_merging_25.c: Ditto. + * gcc.dg/store_merging_28.c: Ditto. + * gcc.dg/store_merging_30.c: Ditto. + * gcc.dg/store_merging_5.c: Ditto. + * gcc.dg/store_merging_7.c: Ditto. + * gcc.dg/store_merging_8.c: Ditto. + * gcc.dg/strlenopt-85.c: Ditto. + * gcc.dg/tree-ssa/dump-6.c: Ditto. + * gcc.dg/tree-ssa/pr19210-1.c: Ditto. + * gcc.dg/tree-ssa/pr47059.c: Ditto. + * gcc.dg/tree-ssa/pr86017.c: Ditto. + * gcc.dg/tree-ssa/pr91482.c: Ditto. + * gcc.dg/tree-ssa/predcom-1.c: Ditto. + * gcc.dg/tree-ssa/predcom-dse-3.c: Ditto. + * gcc.dg/tree-ssa/prefetch-3.c: Ditto. + * gcc.dg/tree-ssa/prefetch-6.c: Ditto. + * gcc.dg/tree-ssa/prefetch-8.c: Ditto. + * gcc.dg/tree-ssa/prefetch-9.c: Ditto. + * gcc.dg/tree-ssa/ssa-dse-18.c: Ditto. + * gcc.dg/tree-ssa/ssa-dse-19.c: Ditto. + * gcc.dg/uninit-40.c: Ditto. + * gcc.dg/unroll-7.c: Ditto. + * gcc.misc-tests/help.exp: Ditto. + * gcc.target/i386/avx512vpopcntdqvl-vpopcntd-1.c: Ditto. + * gcc.target/i386/pr34012.c: Ditto. + * gcc.target/i386/pr49781-1.c: Ditto. + * gcc.target/i386/pr95798-1.c: Ditto. + * gcc.target/i386/pr95798-2.c: Ditto. + * gfortran.dg/pr77498.f: Ditto. + 2021-10-07 Patrick Palka <ppalka@redhat.com> PR c++/61355 diff --git a/gcc/testsuite/c-c++-common/Wstringop-overflow-2-novec.c b/gcc/testsuite/c-c++-common/Wstringop-overflow-2-novec.c new file mode 100644 index 0000000..3c34ad3 --- /dev/null +++ b/gcc/testsuite/c-c++-common/Wstringop-overflow-2-novec.c @@ -0,0 +1,126 @@ +/* PR middle-end/91458 - inconsistent warning for writing past the end + of an array member + { dg-do compile } + { dg-options "-O2 -fno-tree-vectorize -Wall -Wno-array-bounds -fno-ipa-icf" } */ + +void sink (void*); + +// Exercise trailing one-element array members. + +struct A1 +{ + char n; + char a[1]; // { dg-message "destination object" "note" } +}; + +// Verify warning for access to a definition with an initializer that doesn't +// initialize the one-element array member. +struct A1 a1__ = { 0 }; + +void ga1__ (void) +{ + a1__.a[0] = 0; + a1__.a[1] = 1; // { dg-warning "\\\[-Wstringop-overflow" } + a1__.a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" } + + struct A1 a = { 1 }; + a.a[0] = 0; + a.a[1] = 1; // { dg-warning "\\\[-Wstringop-overflow" } + a.a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" } + sink (&a); +} + +// Verify warning for access to a definition with an initializer that +// initializes the one-element array member to empty. +struct A1 a1_0 = { 0, { } }; + +void ga1_0_ (void) +{ + a1_0.a[0] = 0; + a1_0.a[1] = 1; // { dg-warning "\\\[-Wstringop-overflow" } + a1_0.a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" } + + struct A1 a = { 1, { } }; + a.a[0] = 0; + a.a[1] = 1; // { dg-warning "\\\[-Wstringop-overflow" } + a.a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" } + sink (&a); +} + +// Verify warning for access to a definition with an initializer that +// initializes the one-element array member. +struct A1 a1_1 = { 0, { 1 } }; + +void ga1_1 (void) +{ + a1_1.a[0] = 0; + a1_1.a[1] = 1; // { dg-warning "\\\[-Wstringop-overflow" } + a1_1.a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" } + + struct A1 a = { 0, { 1 } }; + a.a[0] = 0; + a.a[1] = 1; // { dg-warning "\\\[-Wstringop-overflow" } + a.a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" } + sink (&a); +} + +// Exercise interior one-element array members (verify they're not +// treated as trailing. + +struct A1i +{ + char n; + char a[1]; // { dg-message "destination object" } + char x; +}; + +// Verify warning for access to a definition with an initializer that doesn't +// initialize the one-element array member. +struct A1i a1i__ = { 0 }; + +void ga1i__ (void) +{ + a1i__.a[0] = 0; + a1i__.a[1] = 1; // { dg-warning "\\\[-Wstringop-overflow" } + a1i__.a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" } + + struct A1i a = { 0 }; + a.a[0] = 0; + a.a[1] = 1; // { dg-warning "\\\[-Wstringop-overflow" } + a.a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" } + sink (&a); +} + +// Verify warning for access to a definition with an initializer that +// initializes the one-element array member to empty. +struct A1 a1i_0 = { 0, { } }; + +void ga1i_0_ (void) +{ + a1i_0.a[0] = 0; + a1i_0.a[1] = 1; // { dg-warning "\\\[-Wstringop-overflow" } + a1i_0.a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" } + + struct A1 a = { 0, { } }; + a.a[0] = 0; + a.a[1] = 1; // { dg-warning "\\\[-Wstringop-overflow" } + a.a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" } + sink (&a); +} + +// Verify warning for access to a definition with an initializer that +// initializes the one-element array member. +struct A1 a1i_1 = { 0, { 1 } }; + +void ga1i_1 (void) +{ + a1i_1.a[0] = 0; + a1i_1.a[1] = 1; // { dg-warning "\\\[-Wstringop-overflow" } + a1i_1.a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" } + + struct A1 a = { 0, { 1 } }; + a.a[0] = 1; + a.a[1] = 2; // { dg-warning "\\\[-Wstringop-overflow" } + a.a[2] = 3; // { dg-warning "\\\[-Wstringop-overflow" } + sink (&a); +} diff --git a/gcc/testsuite/c-c++-common/Wstringop-overflow-2.c b/gcc/testsuite/c-c++-common/Wstringop-overflow-2.c index 7e9da8a..ca38bda 100644 --- a/gcc/testsuite/c-c++-common/Wstringop-overflow-2.c +++ b/gcc/testsuite/c-c++-common/Wstringop-overflow-2.c @@ -190,7 +190,7 @@ void ga1__ (void) struct A1 a = { 1 }; a.a[0] = 0; a.a[1] = 1; // { dg-warning "\\\[-Wstringop-overflow" } - a.a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" "" { xfail { i?86-*-* x86_64-*-* } } } + a.a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" "pr102462" { xfail { vect_slp_v2qi_store } } } sink (&a); } @@ -207,7 +207,7 @@ void ga1_0_ (void) struct A1 a = { 1, { } }; a.a[0] = 0; a.a[1] = 1; // { dg-warning "\\\[-Wstringop-overflow" } - a.a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" "" { xfail { i?86-*-* x86_64-*-* } } } + a.a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" "pr102462" { xfail { vect_slp_v2qi_store } } } sink (&a); } @@ -221,10 +221,10 @@ void ga1_1 (void) a1_1.a[1] = 1; // { dg-warning "\\\[-Wstringop-overflow" } a1_1.a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" } - struct A1 a = { 0, { 1 } }; // { dg-warning "\\\[-Wstringop-overflow" { target { i?86-*-* x86_64-*-* } } } + struct A1 a = { 0, { 1 } }; // { dg-warning "\\\[-Wstringop-overflow" "pr102706" { target { vect_slp_v4qi_store } } } a.a[0] = 0; - a.a[1] = 1; // { dg-warning "\\\[-Wstringop-overflow" "" { xfail { i?86-*-* x86_64-*-* } } } - a.a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" "" { xfail { i?86-*-* x86_64-*-* } } } + a.a[1] = 1; // { dg-warning "\\\[-Wstringop-overflow" "" { xfail { vect_slp_v4qi_store } } } + a.a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" "" { xfail { vect_slp_v4qi_store } } } sink (&a); } @@ -289,7 +289,7 @@ void ga1i__ (void) struct A1i a = { 0 }; a.a[0] = 0; a.a[1] = 1; // { dg-warning "\\\[-Wstringop-overflow" } - a.a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" "" { xfail { i?86-*-* x86_64-*-* } } } + a.a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" "pr102462" { xfail { vect_slp_v2qi_store } } } sink (&a); } @@ -306,7 +306,7 @@ void ga1i_0_ (void) struct A1 a = { 0, { } }; a.a[0] = 0; a.a[1] = 1; // { dg-warning "\\\[-Wstringop-overflow" } - a.a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" "" { xfail { i?86-*-* x86_64-*-* } } } + a.a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" "pr102462" { xfail { vect_slp_v2qi_store } } } sink (&a); } @@ -320,10 +320,10 @@ void ga1i_1 (void) a1i_1.a[1] = 1; // { dg-warning "\\\[-Wstringop-overflow" } a1i_1.a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" } - struct A1 a = { 0, { 1 } }; // { dg-warning "\\\[-Wstringop-overflow" { target { i?86-*-* x86_64-*-* } } } + struct A1 a = { 0, { 1 } }; // { dg-warning "\\\[-Wstringop-overflow" "pr102462" { target { vect_slp_v4qi_store } } } a.a[0] = 1; - a.a[1] = 2; // { dg-warning "\\\[-Wstringop-overflow" "" { xfail { i?86-*-* x86_64-*-* } } } - a.a[2] = 3; // { dg-warning "\\\[-Wstringop-overflow" "" { xfail { i?86-*-* x86_64-*-* } } } + a.a[1] = 2; // { dg-warning "\\\[-Wstringop-overflow" "pr102462" { xfail { vect_slp_v4qi_store } } } + a.a[2] = 3; // { dg-warning "\\\[-Wstringop-overflow" "pr102462" { xfail { vect_slp_v4qi_store } } } sink (&a); } diff --git a/gcc/testsuite/c-c++-common/gomp/atomic-4.c b/gcc/testsuite/c-c++-common/gomp/atomic-4.c index 7f27370..5dd18d1 100644 --- a/gcc/testsuite/c-c++-common/gomp/atomic-4.c +++ b/gcc/testsuite/c-c++-common/gomp/atomic-4.c @@ -8,7 +8,7 @@ int *bar(void); void f1(void) { #pragma omp atomic - a[4] += 1; + a[3] += 1; #pragma omp atomic *p += 1; #pragma omp atomic diff --git a/gcc/testsuite/c-c++-common/gomp/loop-8.c b/gcc/testsuite/c-c++-common/gomp/loop-8.c new file mode 100644 index 0000000..d66bbcd --- /dev/null +++ b/gcc/testsuite/c-c++-common/gomp/loop-8.c @@ -0,0 +1,10 @@ +void +foo (void) +{ + int a[1024]; + int *p, *q; + #pragma omp parallel for collapse(2) + for (p = &a[0]; p < &a[512]; p++) + for (q = p + 64; q < p + 128; q++) + ; +} diff --git a/gcc/testsuite/c-c++-common/gomp/loop-9.c b/gcc/testsuite/c-c++-common/gomp/loop-9.c new file mode 100644 index 0000000..a64ad98 --- /dev/null +++ b/gcc/testsuite/c-c++-common/gomp/loop-9.c @@ -0,0 +1,38 @@ +int *qux (int *); + +void +foo (void) +{ + int a[1024]; + int *p; + short *q; + __PTRDIFF_TYPE__ r; + #pragma omp parallel for collapse(2) + for (p = &a[0]; p < &a[512]; p++) + for (q = (short *) p + 64; q < (short *) p + 128; q++) /* { dg-error "outer iteration variable 'p' used in initializer expression has type other than 'short int ?\\\*'" } */ + ; + #pragma omp parallel for collapse(2) + for (p = &a[0]; p < &a[512]; p++) + for (r = &a[32] - p; r < 32; r++) /* { dg-error "initializer expression refers to iteration variable 'p'" } */ + ; + #pragma omp parallel for collapse(2) + for (r = 0; r < 64; r++) + for (p = &a[0] + r; p < &a[32] + 3 * r; p++) /* { dg-error "initializer expression refers to iteration variable 'r'" } */ + ; +} + +void +bar (void) +{ + int a[1024]; + int *p, *q, *r; + #pragma omp parallel for collapse(2) + for (p = &a[0]; p < &a[512]; p++) + for (q = p + (&a[16] - qux (p)); q < &a[32]; q++) /* { dg-error "initializer expression refers to iteration variable 'p'" } */ + ; + #pragma omp parallel for collapse(3) + for (p = &a[0]; p < &a[512]; p++) + for (q = &a[0]; q < &a[512]; q++) + for (r = p; r < q + 32; r++) /* { dg-error "two different outer iteration variables 'p' and 'q' used in a single loop" } */ + ; +} diff --git a/gcc/testsuite/c-c++-common/gomp/pr102640.c b/gcc/testsuite/c-c++-common/gomp/pr102640.c new file mode 100644 index 0000000..00ebab9 --- /dev/null +++ b/gcc/testsuite/c-c++-common/gomp/pr102640.c @@ -0,0 +1,44 @@ +/* PR c++/102640 */ +/* { dg-do compile } */ +/* { dg-additional-options "-fdump-tree-gimple -fdump-tree-omplower" } */ +/* Verify var[123] are mapped without any copying, because they are + mentioned in declare target directive to clauses. */ +/* { dg-final { scan-tree-dump-not "firstprivate\\\(var\[123]\\\)" "gimple" } } */ +/* { dg-final { scan-tree-dump-not ".omp_data_arr.\[0-9]*.var" "omplower" } } */ +/* { dg-final { scan-tree-dump-not ".omp_data_i->var" "omplower" } } */ + +void +foo (void) +{ + extern int var1; + #pragma omp declare target to (var1) + + #pragma omp target + var1++; +} + +int +bar (int x) +{ + extern int var2; + #pragma omp declare target to (var2) + if (x) + return var2; + #pragma omp target + var2++; + return -1; +} +#pragma omp declare target to (bar) + +#pragma omp declare target +int +baz (int x) +{ + extern int var3; + if (x) + return var3; + #pragma omp target + var3++; + return -1; +} +#pragma omp end declare target diff --git a/gcc/testsuite/c-c++-common/gomp/sections1.c b/gcc/testsuite/c-c++-common/gomp/sections1.c index 8c8ab91..417d205 100644 --- a/gcc/testsuite/c-c++-common/gomp/sections1.c +++ b/gcc/testsuite/c-c++-common/gomp/sections1.c @@ -50,7 +50,7 @@ foo () #pragma omp sections { bar (12); - bar (13); /* { dg-error "pragma omp section" } */ + bar (13); #pragma omp section bar (14); } @@ -63,11 +63,29 @@ foo () bar (15); #pragma omp section bar (16); - bar (17); /* { dg-error "pragma omp section" } */ + bar (17); } #pragma omp sections { bar (18); #pragma omp section } /* { dg-error "expression before" } */ + #pragma omp sections + { + #pragma omp section + #pragma omp section /* { dg-error "may only be used in" } */ + bar (19); + } + #pragma omp sections + { + bar (20); + #pragma omp section + #pragma omp section /* { dg-error "may only be used in" } */ + bar (21); + } + #pragma omp sections + { + bar (22); + #pragma omp section + } /* { dg-error "expression before" } */ } diff --git a/gcc/testsuite/c-c++-common/ubsan/pr64888.c b/gcc/testsuite/c-c++-common/ubsan/pr64888.c new file mode 100644 index 0000000..6319c2f --- /dev/null +++ b/gcc/testsuite/c-c++-common/ubsan/pr64888.c @@ -0,0 +1,27 @@ +/* PR middle-end/64888 */ +/* { dg-do compile { target fopenmp } } */ +/* { dg-options "-fopenmp -fsanitize=undefined" } */ + +int a, b; + +void +foo () +{ + int c; +#pragma omp parallel default (none) shared (a, b) private (c) + { + c = a / b; /* { dg-bogus "not specified in enclosing" } */ + (void) c; + } +#pragma omp task default (none) shared (a, b) private (c) + { + c = a << b; /* { dg-bogus "not specified in enclosing" } */ + (void) c; + } +#pragma omp teams default (none) shared (a, b) + { + int d[a]; /* { dg-bogus "not specified in enclosing" } */ + d[0] = 0; + (void) d[0]; + } +} diff --git a/gcc/testsuite/g++.dg/cpp0x/constexpr-inst1.C b/gcc/testsuite/g++.dg/cpp0x/constexpr-inst1.C new file mode 100644 index 0000000..3ce513d --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp0x/constexpr-inst1.C @@ -0,0 +1,17 @@ +// Test that we don't uselessly instantiate f<A> immediately while parsing g. +// Doing so is permitted by the standard, but has no benefit and breaks code +// unnecessarily. + +// { dg-do compile { target c++11 } } + +// -O activates the call to maybe_constant_value in cp_fold. +// { dg-additional-options -O } + +template <class T> +constexpr int f (const T* p) { return p->i; } + +constexpr int g(const struct A* p) { return f(p); } + +struct A { int i; }; + +// Instantiating f<A> at EOF works fine. diff --git a/gcc/testsuite/g++.dg/cpp23/consteval-if11.C b/gcc/testsuite/g++.dg/cpp23/consteval-if11.C new file mode 100644 index 0000000..a22736c --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp23/consteval-if11.C @@ -0,0 +1,27 @@ +// PR c++/102753 +// { dg-do compile { target c++20 } } +// { dg-options "" } + +struct S { + constexpr S () : s (0) {} + consteval int foo () { return 1; } + virtual consteval int bar () { return 2; } + int s; +}; + +consteval int foo () { return 42; } + +constexpr int +bar () +{ + if consteval { // { dg-warning "'if consteval' only available with" "" { target c++20_only } } + int (*fn1) () = foo; + int (S::*fn2) () = &S::foo; + int (S::*fn3) () = &S::bar; + S s; + return fn1 () + (s.*fn2) () + (s.*fn3) (); + } + return 0; +} + +static_assert (bar () == 45); diff --git a/gcc/testsuite/g++.dg/cpp23/consteval-if12.C b/gcc/testsuite/g++.dg/cpp23/consteval-if12.C new file mode 100644 index 0000000..7a47680 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp23/consteval-if12.C @@ -0,0 +1,34 @@ +// PR c++/102753 +// { dg-do compile { target c++20 } } +// { dg-options "" } + +struct S { + constexpr S () : s (0) {} + consteval int foo () { return 1; } + virtual consteval int bar () { return 2; } + int s; +}; + +consteval int foo () { return 42; } +consteval auto baz () { return foo; } +consteval auto qux () { return &S::foo; } +consteval auto corge () { return &S::bar; } + +constexpr int +bar () +{ + S s; + if consteval { // { dg-warning "'if consteval' only available with" "" { target c++20_only } } + constexpr auto fn1 = foo; // { dg-error "immediate evaluation returns address of immediate function" } + constexpr auto fn2 = &foo; // { dg-error "immediate evaluation returns address of immediate function" } + constexpr auto fn3 = &S::foo; // { dg-error "immediate evaluation returns address of immediate function" } + constexpr auto fn4 = &S::bar; // { dg-error "immediate evaluation returns address of immediate function" } + constexpr auto fn5 = baz (); // { dg-error "immediate evaluation returns address of immediate function" } + constexpr auto fn6 = qux (); // { dg-error "immediate evaluation returns address of immediate function" } + constexpr auto fn7 = corge (); // { dg-error "immediate evaluation returns address of immediate function" } + return fn1 () + fn2 () + (s.*fn3) () + (s.*fn4) () + fn5 () + (s.*fn6) () + (s.*fn7) (); + } + return 0; +} + +auto a = bar (); diff --git a/gcc/testsuite/g++.dg/cpp23/init-stmt1.C b/gcc/testsuite/g++.dg/cpp23/init-stmt1.C new file mode 100644 index 0000000..29e3256a --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp23/init-stmt1.C @@ -0,0 +1,31 @@ +// PR c++/102617 +// P2360R0: Extend init-statement to allow alias-declaration +// { dg-do compile { target c++20 } } +// Test valid use. + +int v[10]; + +void +g () +{ + for (using T = int; (T) false;) // { dg-error "only available with" "" { target c++20_only } } + ; + for (using T = int; T e : v) // { dg-error "only available with" "" { target c++20_only } } + (void) e; + if (using T = int; true) // { dg-error "only available with" "" { target c++20_only } } + { + T x = 0; + (void) x; + } + if constexpr (using T = int; true) // { dg-error "only available with" "" { target c++20_only } } + { + T x = 0; + (void) x; + } + switch (using T = int; 42) // { dg-error "only available with" "" { target c++20_only } } + case 42: + { + T x = 0; + (void) x; + } +} diff --git a/gcc/testsuite/g++.dg/cpp23/init-stmt2.C b/gcc/testsuite/g++.dg/cpp23/init-stmt2.C new file mode 100644 index 0000000..ca6201b --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp23/init-stmt2.C @@ -0,0 +1,25 @@ +// PR c++/102617 +// P2360R0: Extend init-statement to allow alias-declaration +// { dg-do compile { target c++23 } } +// Test invalid use. + +int v[10]; +namespace N { using X = int; } + +void +g () +{ + for (using N::X; false;) // { dg-error "expected" } + ; + for (using N::X; int e : v) // { dg-error "expected" } + (void) e; + for (using T = int; using U = int; int e : v) // { dg-error "" } + ; + if (using N::X; false) // { dg-error "expected" } + {} + switch (using N::X; 0) // { dg-error "expected" } + ; + if (using T = int;) // { dg-error "expected" } + { + } +} diff --git a/gcc/testsuite/g++.dg/cpp2a/class-deduction-alias11.C b/gcc/testsuite/g++.dg/cpp2a/class-deduction-alias11.C new file mode 100644 index 0000000..87eb3e6 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp2a/class-deduction-alias11.C @@ -0,0 +1,12 @@ +// PR c++/102643 +// { dg-do compile { target c++20 } } + +template<class _Tp, class> +struct vector { + typedef int allocator_type; + vector(_Tp, allocator_type = allocator_type()); +}; + +template<class T> using vector_mm = vector<T, int>; + +vector_mm v(0); diff --git a/gcc/testsuite/g++.dg/cpp2a/consteval13.C b/gcc/testsuite/g++.dg/cpp2a/consteval13.C index a2e1750..09ea6b7 100644 --- a/gcc/testsuite/g++.dg/cpp2a/consteval13.C +++ b/gcc/testsuite/g++.dg/cpp2a/consteval13.C @@ -10,8 +10,8 @@ void foo () { auto qux = [] (fnptr a = quux ()) consteval { return a (); }; - constexpr auto c = qux (baz); // { dg-error "28:taking address of an immediate function" } - constexpr auto d = qux (bar); // { dg-error "28:taking address of an immediate function" } + constexpr auto c = qux (baz); + constexpr auto d = qux (bar); static_assert (c == 1); static_assert (d == 42); } diff --git a/gcc/testsuite/g++.dg/cpp2a/consteval20.C b/gcc/testsuite/g++.dg/cpp2a/consteval20.C new file mode 100644 index 0000000..2c35963 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp2a/consteval20.C @@ -0,0 +1,24 @@ +// PR c++/102753 +// { dg-do compile { target c++20 } } + +struct S { + consteval int foo () const { return 42; } +}; + +constexpr S s; + +int +bar () +{ + return (s.*&S::foo) (); // { dg-error "taking address of an immediate function" } +} + +constexpr auto a = &S::foo; // { dg-error "taking address of an immediate function" } + +consteval int +baz () +{ + return (s.*&S::foo) (); +} + +static_assert (baz () == 42); diff --git a/gcc/testsuite/g++.dg/cpp2a/consteval21.C b/gcc/testsuite/g++.dg/cpp2a/consteval21.C new file mode 100644 index 0000000..06ec705 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp2a/consteval21.C @@ -0,0 +1,35 @@ +// PR c++/102753 +// { dg-do compile { target c++20 } } + +struct S { + constexpr S () : s (0) {} + consteval int foo () { return 1; } + virtual consteval int bar () { return 2; } + int s; +}; + +consteval int foo () { return 42; } + +consteval int +bar (int (*fn) () = &foo) +{ + return fn (); +} + +consteval int +baz (int (S::*fn) () = &S::foo) +{ + S s; + return (s.*fn) (); +} + +consteval int +qux (int (S::*fn) () = &S::bar) +{ + S s; + return (s.*fn) (); +} + +static_assert (bar () == 42); +static_assert (baz () == 1); +static_assert (qux () == 2); diff --git a/gcc/testsuite/g++.dg/cpp2a/consteval22.C b/gcc/testsuite/g++.dg/cpp2a/consteval22.C new file mode 100644 index 0000000..5c36371 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp2a/consteval22.C @@ -0,0 +1,34 @@ +// PR c++/102753 +// { dg-do compile { target c++20 } } + +struct S { + constexpr S () : s (0) {} + consteval int foo () { return 1; } + virtual consteval int bar () { return 2; } + int s; +}; +typedef int (S::*P) (); + +consteval P +foo () +{ + return &S::foo; +} + +consteval P +bar () +{ + return &S::bar; +} + +consteval int +baz () +{ + S s; + return (s.*(foo ())) () + (s.*(bar ())) (); +} + +static_assert (baz () == 3); + +constexpr P a = foo (); // { dg-error "immediate evaluation returns address of immediate function" } +constexpr P b = bar (); // { dg-error "immediate evaluation returns address of immediate function" } diff --git a/gcc/testsuite/g++.dg/cpp2a/consteval23.C b/gcc/testsuite/g++.dg/cpp2a/consteval23.C new file mode 100644 index 0000000..4c7e844 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp2a/consteval23.C @@ -0,0 +1,13 @@ +// PR c++/102753 +// { dg-do compile { target c++20 } } + +consteval int foo () { return 42; } + +consteval int +bar (int (*fn) () = foo) +{ + return fn (); +} + +static_assert (bar () == 42); +static_assert (bar (foo) == 42); diff --git a/gcc/testsuite/g++.dg/cpp2a/consteval24.C b/gcc/testsuite/g++.dg/cpp2a/consteval24.C new file mode 100644 index 0000000..6d0c63c --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp2a/consteval24.C @@ -0,0 +1,30 @@ +// PR c++/102753 +// { dg-do compile { target c++20 } } + +struct S { + constexpr S () : s (0) {} + consteval int foo () { return 1; } + virtual consteval int bar () { return 2; } + int s; +}; + +consteval int foo () { return 42; } +consteval auto baz () { return foo; } +consteval auto qux () { return &S::foo; } +consteval auto corge () { return &S::bar; } + +consteval int +bar () +{ + S s; + constexpr auto fn1 = foo; // { dg-error "immediate evaluation returns address of immediate function" } + constexpr auto fn2 = &foo; // { dg-error "immediate evaluation returns address of immediate function" } + constexpr auto fn3 = &S::foo; // { dg-error "immediate evaluation returns address of immediate function" } + constexpr auto fn4 = &S::bar; // { dg-error "immediate evaluation returns address of immediate function" } + constexpr auto fn5 = baz (); // { dg-error "immediate evaluation returns address of immediate function" } + constexpr auto fn6 = qux (); // { dg-error "immediate evaluation returns address of immediate function" } + constexpr auto fn7 = corge (); // { dg-error "immediate evaluation returns address of immediate function" } + return fn1 () + fn2 () + (s.*fn3) () + (s.*fn4) () + fn5 () + (s.*fn6) () + (s.*fn7) (); +} + +auto a = bar (); diff --git a/gcc/testsuite/g++.dg/cpp2a/consteval7.C b/gcc/testsuite/g++.dg/cpp2a/consteval7.C index 10e4ea4..23f3d25 100644 --- a/gcc/testsuite/g++.dg/cpp2a/consteval7.C +++ b/gcc/testsuite/g++.dg/cpp2a/consteval7.C @@ -7,7 +7,7 @@ constexpr auto a = bar (); // { dg-error "immediate evaluation returns address o struct S { int b; int (*c) (); }; consteval S baz () { return { 5, foo }; } consteval int qux () { S s = baz (); return s.b + s.c (); } -consteval int quux () { constexpr S s = baz (); return s.b + s.c (); } +consteval int quux () { constexpr S s = baz (); return s.b + s.c (); } // { dg-error "immediate evaluation returns address of immediate function 'consteval int foo\\(\\)'" } constexpr auto d = baz (); // { dg-error "immediate evaluation returns address of immediate function 'consteval int foo\\(\\)'" } constexpr auto e = qux (); constexpr auto f = quux (); diff --git a/gcc/testsuite/g++.dg/cpp2a/constexpr-virtual19.C b/gcc/testsuite/g++.dg/cpp2a/constexpr-virtual19.C new file mode 100644 index 0000000..cb0d1be --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp2a/constexpr-virtual19.C @@ -0,0 +1,11 @@ +// PR c++/102786 +// { dg-do compile { target c++20 } } + +struct S { + virtual constexpr int foo () const { return 42; } +}; + +constexpr S s; +constexpr auto a = &S::foo; +constexpr auto b = (s.*a) (); +constexpr auto c = (s.*&S::foo) (); diff --git a/gcc/testsuite/g++.dg/ext/vla22.C b/gcc/testsuite/g++.dg/ext/vla22.C index 967adb9..2308ee7 100644 --- a/gcc/testsuite/g++.dg/ext/vla22.C +++ b/gcc/testsuite/g++.dg/ext/vla22.C @@ -6,4 +6,4 @@ void f () { const int tbl[(long) "h"] = { 12 }; // { dg-error "size of array .tbl. is not an integral constant-expression" } -} // { dg-warning "narrowing conversion" "" { target c++11 } .-1 } +} diff --git a/gcc/testsuite/g++.dg/gomp/attrs-6.C b/gcc/testsuite/g++.dg/gomp/attrs-6.C index 30b47e1..af8b973 100644 --- a/gcc/testsuite/g++.dg/gomp/attrs-6.C +++ b/gcc/testsuite/g++.dg/gomp/attrs-6.C @@ -26,6 +26,41 @@ foo () #pragma omp section { a[3]++; } } + #pragma omp parallel sections + { + #pragma omp section + a[0]++; + a[4]++; + l1: a[5]++; + if (a[5] == 42) goto l1; + [[omp::directive (section)]] { + a[1]++; + a[6]++; + } [[omp::directive (section)]] + a[2]++; + a[7]++; + #pragma omp section + { a[3]++; } + a[8]++; + } + [[omp::directive (parallel sections)]] + { + #pragma omp section + a[0]++; + a[4]++; + [[omp::directive (section)]] { + a[1]++; + a[5]++; + } [[omp::directive (section)]] + a[2]++; + l2: a[6]++; + if (a[6] == 42) + goto l2; + a[7]++; + #pragma omp section + a[8]++; + { a[3]++; } + } } int @@ -46,5 +81,23 @@ bar (int a, int *c, int *d, int *e, int *f) #pragma omp scan inclusive (a) d[i] = a; } + #pragma omp simd reduction (inscan, +: a) + for (i = 0; i < 64; i++) + { + int t = a; + d[i] = t; + [[omp::directive (scan, exclusive (a))]] + int u = c[i]; + a += u; + } + [[omp::directive (simd reduction (inscan, +: a))]] + for (i = 0; i < 64; i++) + { + int t = c[i]; + a += t; + #pragma omp scan inclusive (a) + int u = a; + d[i] = u; + } return a; } diff --git a/gcc/testsuite/g++.dg/gomp/attrs-7.C b/gcc/testsuite/g++.dg/gomp/attrs-7.C index cf84281..900ef66 100644 --- a/gcc/testsuite/g++.dg/gomp/attrs-7.C +++ b/gcc/testsuite/g++.dg/gomp/attrs-7.C @@ -29,29 +29,33 @@ bar (int a, int *c, int *d, int *e, int *f) { d[i] = a; [[omp::sequence (omp::directive (parallel), omp::directive (scan, exclusive (a)))]] // { dg-error "must be the only specified attribute on a statement" } - a += c[i]; // { dg-error "#pragma omp scan" "" { target *-*-* } .-1 } - } + // { dg-error "#pragma omp scan" "" { target *-*-* } .-1 } + a += c[i]; // { dg-error "expected" } + } // { dg-error "expected" } [[omp::directive (parallel for reduction (inscan, +: a))]] // { dg-error "'a' specified in 'inscan' 'reduction' clause but not in 'scan' directive clause" } for (i = 0; i < 64; i++) { a += c[i]; [[omp::sequence (directive (scan inclusive (a)), directive (critical))]] // { dg-error "must be the only specified attribute on a statement" } - d[i] = a; // { dg-error "#pragma omp scan" "" { target *-*-* } .-1 } - } + // { dg-error "#pragma omp scan" "" { target *-*-* } .-1 } + d[i] = a; // { dg-error "expected" } + } // { dg-error "expected" } [[omp::directive (parallel for reduction (inscan, +: a))]] // { dg-error "'a' specified in 'inscan' 'reduction' clause but not in 'scan' directive clause" } for (i = 0; i < 64; i++) { d[i] = a; [[gnu::cold]] [[omp::directive (scan, exclusive (a))]] // { dg-error "must be the only specified attribute on a statement" } - a += c[i]; // { dg-error "#pragma omp scan" "" { target *-*-* } .-1 } - } + // { dg-error "#pragma omp scan" "" { target *-*-* } .-1 } + a += c[i]; // { dg-error "expected" } + } // { dg-error "expected" } [[omp::directive (parallel for reduction (inscan, +: a))]] // { dg-error "'a' specified in 'inscan' 'reduction' clause but not in 'scan' directive clause" } for (i = 0; i < 64; i++) { d[i] = a; [[omp::directive (scan, exclusive (a)), gnu::cold]] // { dg-error "must be the only specified attribute on a statement" } - a += c[i]; // { dg-error "#pragma omp scan" "" { target *-*-* } .-1 } - } + // { dg-error "#pragma omp scan" "" { target *-*-* } .-1 } + a += c[i]; // { dg-error "expected" } + } // { dg-error "expected" } [[omp::directive (parallel for reduction (inscan, +: a))]] // { dg-error "'a' specified in 'inscan' 'reduction' clause but not in 'scan' directive clause" } for (i = 0; i < 64; i++) { diff --git a/gcc/testsuite/g++.dg/gomp/loop-3.C b/gcc/testsuite/g++.dg/gomp/loop-3.C index 3806e1f..d9b8465 100644 --- a/gcc/testsuite/g++.dg/gomp/loop-3.C +++ b/gcc/testsuite/g++.dg/gomp/loop-3.C @@ -116,7 +116,7 @@ f1 (I<int> &x, I<int> &y, I<int> &u, I<int> &v) for (j = x; j < y; j++) ; #pragma omp for collapse(2) - for (i = x; i < y; i = i + 2) /* { dg-error "initializer expression refers to iteration variable" } */ + for (i = x; i < y; i = i + 2) for (j = i; j < v; j += 2) ; #pragma omp for collapse(2) @@ -128,11 +128,11 @@ f1 (I<int> &x, I<int> &y, I<int> &u, I<int> &v) for (j = baz (&i); j < v; j += 2) /* { dg-error "initializer expression refers to iteration variable" } */ ; #pragma omp for collapse(2) - for (i = x; i < y; i++) /* { dg-error "condition expression refers to iteration variable" } */ + for (i = x; i < y; i++) for (j = v; j > i; j--) ; #pragma omp for collapse(2) - for (i = x; i < y; i++) /* { dg-error "condition expression refers to iteration variable" } */ + for (i = x; i < y; i++) for (j = x; j < i; j++) ; #pragma omp for collapse(2) @@ -234,7 +234,7 @@ f2 (I<int> &x, I<int> &y, I<int> &u, I<int> &v) for (I<int> j = u; j < y; j += 2) ; #pragma omp for collapse(2) - for (I<int> i = x; i < y; i = i + 2) /* { dg-error "initializer expression refers to iteration variable" } */ + for (I<int> i = x; i < y; i = i + 2) for (I<int> j = i; j < v; j += 2) ; #pragma omp for collapse(2) @@ -246,11 +246,11 @@ f2 (I<int> &x, I<int> &y, I<int> &u, I<int> &v) for (I<int> j = baz (&i); j < v; j += 2) /* { dg-error "initializer expression refers to iteration variable" } */ ; #pragma omp for collapse(2) - for (I<int> i = x; i < y; i++) /* { dg-error "condition expression refers to iteration variable" } */ + for (I<int> i = x; i < y; i++) for (I<int> j = v; j > i; j--) ; #pragma omp for collapse(2) - for (I<int> i = x; i < y; i++) /* { dg-error "condition expression refers to iteration variable" } */ + for (I<int> i = x; i < y; i++) for (I<int> j = x; j < i; j++) ; #pragma omp for collapse(2) diff --git a/gcc/testsuite/g++.dg/gomp/loop-7.C b/gcc/testsuite/g++.dg/gomp/loop-7.C new file mode 100644 index 0000000..9466c1c --- /dev/null +++ b/gcc/testsuite/g++.dg/gomp/loop-7.C @@ -0,0 +1,22 @@ +// PR c++/102854 +// { dg-do compile } + +template <typename T> +void +foo (T N, T M) +{ + #pragma omp parallel for collapse(2) + for (T i = 0; i < N; ++i) + for (T k = i; k < M; ++k) + ; + #pragma omp parallel for collapse(2) + for (T i = 0; i < N; ++i) + for (T k = i; k < 2 * i; ++k) + ; +} + +void +bar () +{ + foo (5, 10); +} diff --git a/gcc/testsuite/g++.dg/gomp/sections-2.C b/gcc/testsuite/g++.dg/gomp/sections-2.C index aabdfaf..6d8305a 100644 --- a/gcc/testsuite/g++.dg/gomp/sections-2.C +++ b/gcc/testsuite/g++.dg/gomp/sections-2.C @@ -19,11 +19,11 @@ void foo(void) { #pragma omp section bar(2); - bar(3); // { dg-error "expected" } + bar(3); bar(4); #pragma omp section bar(5); - bar(6); // { dg-error "expected" } + bar(6); bar(7); } } diff --git a/gcc/testsuite/g++.dg/pr102796.C b/gcc/testsuite/g++.dg/pr102796.C new file mode 100644 index 0000000..6ad1008 --- /dev/null +++ b/gcc/testsuite/g++.dg/pr102796.C @@ -0,0 +1,18 @@ +// { dg-do compile } +// { dg-options "-O3 -fno-tree-ccp -fno-tree-fre -fno-tree-forwprop -std=c++17" } + +namespace std { +template <class _E> +struct initializer_list { + const int* __begin_; + decltype(sizeof(int)) __size_; +}; +} // namespace std +struct destroyme1 {}; +struct witharg1 { + witharg1(const destroyme1&); + ~witharg1(); +}; +std::initializer_list globalInitList2 = {witharg1(destroyme1()), + witharg1(destroyme1())}; + diff --git a/gcc/testsuite/g++.dg/template/crash90.C b/gcc/testsuite/g++.dg/template/crash90.C index 125ab0a..fee7dc5 100644 --- a/gcc/testsuite/g++.dg/template/crash90.C +++ b/gcc/testsuite/g++.dg/template/crash90.C @@ -4,5 +4,6 @@ template < unsigned > struct A ; template < typename > struct B ; -template < typename T , A < B < T > {} // { dg-error "parse error|non-type|initializer" } +template < typename T , A < B < T > {} // { dg-error "parse error|non-type" } // { dg-error "39:expected" "" { target *-*-* } .-1 } +// { dg-error "37:initializer list" "" { target c++98_only } .-2 } diff --git a/gcc/testsuite/g++.dg/template/fnspec2.C b/gcc/testsuite/g++.dg/template/fnspec2.C new file mode 100644 index 0000000..7a4b101 --- /dev/null +++ b/gcc/testsuite/g++.dg/template/fnspec2.C @@ -0,0 +1,9 @@ +template <class T> +void f(T); + +template<> void f(int, ...); // { dg-error "match" } + +template <class T> +void g(T, ...); + +template<> void g(int); // { dg-error "match" } diff --git a/gcc/testsuite/g++.dg/template/parm-cv1.C b/gcc/testsuite/g++.dg/template/parm-cv1.C new file mode 100644 index 0000000..2677992 --- /dev/null +++ b/gcc/testsuite/g++.dg/template/parm-cv1.C @@ -0,0 +1,15 @@ +// CWG 1001 + +template<class T> struct A { + typedef T arr[3]; +}; + +template<class T> void f(const typename A<T>::arr) { } // #1 + +template void f<int>(const A<int>::arr); + +template <class T> struct B { + void g(T); +}; + +template <class T> void B<T>::g(const T) { } // #2 diff --git a/gcc/testsuite/g++.dg/template/parm-cv2.C b/gcc/testsuite/g++.dg/template/parm-cv2.C new file mode 100644 index 0000000..cd40e86 --- /dev/null +++ b/gcc/testsuite/g++.dg/template/parm-cv2.C @@ -0,0 +1,23 @@ +// PR c++/51851 + +template<class T> +struct A +{ + typedef double Point[2]; + virtual double calculate(const Point point) const = 0; +}; + +template<class T> +struct B : public A<T> +{ + virtual double calculate(const typename A<T>::Point point) const + { + return point[0]; + } +}; + +int main() +{ + B<int> b; + return 0; +} diff --git a/gcc/testsuite/g++.dg/template/parm-cv3.C b/gcc/testsuite/g++.dg/template/parm-cv3.C new file mode 100644 index 0000000..1b69c3b2 --- /dev/null +++ b/gcc/testsuite/g++.dg/template/parm-cv3.C @@ -0,0 +1,142 @@ +// CWG 1001/1322 + +// PR c++/101402 +// PR c++/102033 +// PR c++/102034 +// PR c++/102039 +// PR c++/102044 + +namespace test2{ +template <class T> +void f(const T); + +template<> +void f<int[]>(const int*){} +} + +namespace test3{ +template <class T> +struct A{ +void f(T); +}; + +template<class T> +void A<T>::f(const T){} + +template<> +void A<int[3]>::f(const int*){} +} + +namespace test4 { +template<class TA> +struct A{ + template<class TB> + struct B{ + typedef TB Arr3[3]; + }; +}; +template<class TA, class TB> +void f(const typename A<TA>::template B<TB>::Arr3){} +template <> +void f<int, char>(const typename A<int>::B<char>::Arr3){} +} + +namespace test5 +{ +struct A{ + typedef int Arr3[3]; +}; + +template<class T> +void f(const typename T::Arr3){} + +template<> +void f<A>(const int[3]){} +} + +namespace test6 +{ +struct A{ + typedef int Arr3[3]; +}; +template<class T> +void f(const typename T::Arr3){} +template<> +void f<A>(const int*){} +} + +#if __cpp_alias_templates +namespace test7 +{ +template<class TA> +struct A{ + template<class TB> + using Type=TB[3]; +}; +template<class TA, class TB> +void f(const typename A<TA>::template Type<TB>){} +template <> +void f<int, char>(const typename A<int>::template Type<char>){} +} +namespace test8 +{ +template<class TA> +struct A{ + template<class TB> + struct B{ + using TB_Alias=TB; + template<class TC=TB_Alias> + struct C{ + typedef TC Arr3[3]; + }; + }; +}; +template<class TA, class TB> +void f(const typename A<TA>::template B<TB>::template C<>::Arr3){} +template <> +void f<int, char>(const typename A<int>::template B<char>::template C<>::Arr3){} +} +#endif + +#if __cpp_decltype +namespace test0 +{ +template <class T> +struct A{ + T arr3[3]; +}; +template <class T> +void f(const decltype(A<T>::arr3)){} +template <> +void f<int>(const int[3]){} +} + +#if __cpp_variable_templates +namespace test9 +{ +template<unsigned int N, class T> +void f(const T[N]){} + +template<unsigned int N, class T> +using fPtr=decltype(f<N,T>)*; + +template<unsigned int N, class T> +fPtr<N,T> af[N]={&f<N,T>}; + +template<unsigned int N, class T> +void g(const decltype(af<N,T>)){} + +template<> +void g<1,int>(const fPtr<1,int>[1]){} +} +#endif +#endif + +#if __cpp_concepts +template<class T> +concept IsLambdaAry3=__is_same(T, decltype(+[]{})[3]); +template<IsLambdaAry3 T> +void bar(const T){} +template<> +void bar<decltype(+[]{})[3]>(const decltype(+[]{})[3]){} +#endif diff --git a/gcc/testsuite/g++.dg/tls/pr102642.C b/gcc/testsuite/g++.dg/tls/pr102642.C new file mode 100644 index 0000000..e3236d3 --- /dev/null +++ b/gcc/testsuite/g++.dg/tls/pr102642.C @@ -0,0 +1,10 @@ +// PR c++/102642 +// { dg-do compile { target c++11 } } + +thread_local int *z; // { dg-message "previous declaration" } + +void +foo () +{ + extern thread_local int z; // { dg-error "conflicting declaration" } +} diff --git a/gcc/testsuite/g++.dg/torture/pr10148.C b/gcc/testsuite/g++.dg/torture/pr10148.C new file mode 100644 index 0000000..ed278f9 --- /dev/null +++ b/gcc/testsuite/g++.dg/torture/pr10148.C @@ -0,0 +1,52 @@ +/* { dg-do run } */ + +#include <stdlib.h> +#include <assert.h> + +static bool flag = false; + +class C +{ + bool prev; + +public: + C() : prev(flag) + { + flag = true; + } + + ~C() { + flag = prev; + } +}; + +void* operator new(size_t size) +{ + assert(flag); + return malloc(size); +} + +void operator delete(void *p) +{ + free(p); +} + +void g(int* p) +{ + delete p; +} + +void f() +{ + int* p; + { + C c; + p = new int; + } + g(p); +} + +int main(int, char**) +{ + f(); +} diff --git a/gcc/testsuite/g++.dg/torture/pr102505.C b/gcc/testsuite/g++.dg/torture/pr102505.C new file mode 100644 index 0000000..a846751 --- /dev/null +++ b/gcc/testsuite/g++.dg/torture/pr102505.C @@ -0,0 +1,15 @@ +struct D { int i; int pad alignas(16); }; +struct B : virtual D +{ + int j =84; + int k =84; +}; + +struct C: B { }; + +int main() +{ + C c; + if (c.j != 84 || c.k != 84) + __builtin_abort(); +} diff --git a/gcc/testsuite/g++.dg/tree-ssa/pr94403.C b/gcc/testsuite/g++.dg/tree-ssa/pr94403.C index d47e7fc..5f8f868 100644 --- a/gcc/testsuite/g++.dg/tree-ssa/pr94403.C +++ b/gcc/testsuite/g++.dg/tree-ssa/pr94403.C @@ -3,7 +3,7 @@ // are either big or little endian (not pdp endian). // { dg-do compile { target { lp64 && { i?86-*-* x86_64-*-* powerpc*-*-* aarch64*-*-* } } } } // { dg-require-effective-target store_merge } -// { dg-options "-O2 -fdump-tree-store-merging -std=c++17" } +// { dg-options "-O2 -fno-tree-vectorize -fdump-tree-store-merging -std=c++17" } namespace std { template <typename T> diff --git a/gcc/testsuite/g++.dg/vect/pr102572.cc b/gcc/testsuite/g++.dg/vect/pr102572.cc new file mode 100644 index 0000000..0a71308 --- /dev/null +++ b/gcc/testsuite/g++.dg/vect/pr102572.cc @@ -0,0 +1,14 @@ +// { dg-do compile } +// { dg-additional-options "-O3" } +// { dg-additional-options "-march=skylake-avx512" { target x86_64-*-* i?86-*-* } } + +int a, b, c, f; +void g(bool h, int d[][5]) +{ + for (short i = f; i; i += 1) + { + a = h && d[0][i]; + for (int j = 0; j < 4; j += c) + b = 0; + } +} diff --git a/gcc/testsuite/g++.dg/vect/pr102696.cc b/gcc/testsuite/g++.dg/vect/pr102696.cc new file mode 100644 index 0000000..5560354 --- /dev/null +++ b/gcc/testsuite/g++.dg/vect/pr102696.cc @@ -0,0 +1,16 @@ +// { dg-do compile } +// { dg-additional-options "-O3" } +// { dg-additional-options "-march=skylake-avx512" { target x86_64-*-* i?86-*-* } } + +int a; +extern bool b[][14]; +char h; +void f(short g[][14]) +{ + for (short d = h; d < 21; d += 1) + for (unsigned char e = 0; e < 14; e += 1) + { + a = 0; + b[d][e] = g[d][e]; + } +} diff --git a/gcc/testsuite/g++.dg/vect/pr102788.cc b/gcc/testsuite/g++.dg/vect/pr102788.cc new file mode 100644 index 0000000..fa9c366 --- /dev/null +++ b/gcc/testsuite/g++.dg/vect/pr102788.cc @@ -0,0 +1,32 @@ +// { dg-do run } +// { dg-additional-options "-O3" } + +unsigned long long int var_4 = 235; +unsigned long long int var_5 = 74; +signed char var_12 = -99; +unsigned long long int var_349; +unsigned char var_645; +void test(); + +const unsigned long long &min(const unsigned long long &a, + const unsigned long long &b) +{ + return b < a ? b : a; +} + +void __attribute__((noipa)) test() +{ + for (short c = var_12; c; c += 5) + ; + for (int e = 0; e < 12; e += 1) { + var_349 = var_4 ? 235 : 74; + var_645 = min((unsigned long long)true, var_5 ? var_12 : var_4); + } +} + +int main() +{ + test(); + if (var_645 != 1) + __builtin_abort(); +} diff --git a/gcc/testsuite/g++.dg/warn/Wuninitialized-13.C b/gcc/testsuite/g++.dg/warn/Wuninitialized-13.C index 210e74c..b74a2fa 100644 --- a/gcc/testsuite/g++.dg/warn/Wuninitialized-13.C +++ b/gcc/testsuite/g++.dg/warn/Wuninitialized-13.C @@ -1,11 +1,14 @@ /* PR c/98597 - ICE in -Wuninitialized printing a MEM_REF { dg-do compile } - { dg-options "-O2 -Wall" } */ + { dg-options "-O2 -Wall -fno-tree-vectorize" } */ +/* After vectorization, the location of the warning that's off, + the warning itself is still issued but it's swallowed by + the dg-prune-output directive. Refer to pr102700. */ struct shared_count { shared_count () { } shared_count (shared_count &r) - : pi (r.pi) { } // { dg-warning "\\\[-Wuninitialized" "" { xfail { i?86-*-* x86_64-*-* } } } + : pi (r.pi) { } // { dg-warning "\\\[-Wuninitialized" } int pi; }; diff --git a/gcc/testsuite/g++.target/arm/pr102842.C b/gcc/testsuite/g++.target/arm/pr102842.C new file mode 100644 index 0000000..a2bac66 --- /dev/null +++ b/gcc/testsuite/g++.target/arm/pr102842.C @@ -0,0 +1,30 @@ +/* PR rtl-optimization/102842 */ +/* { dg-do compile } */ +/* { dg-options "-fPIC -O2 -fno-omit-frame-pointer -mthumb -march=armv7-a+fp" } */ + +struct Plane { + using T = float; + T *Row(); +}; +using ImageF = Plane; +long long Mirror_x; +struct EnsurePaddingInPlaceRowByRow { + void Process() { + switch (strategy_) { + case kSlow: + float *row = img_.Row(); + long long xsize = x1_; + while (Mirror_x >= xsize) + if (Mirror_x) + Mirror_x = 2 * xsize - 1; + *row = Mirror_x; + } + } + ImageF img_; + unsigned x1_; + enum { kSlow } strategy_; +}; +void FinalizeImageRect() { + EnsurePaddingInPlaceRowByRow ensure_padding; + ensure_padding.Process(); +} diff --git a/gcc/testsuite/g++.target/i386/pr102639.C b/gcc/testsuite/g++.target/i386/pr102639.C new file mode 100644 index 0000000..f094e4d --- /dev/null +++ b/gcc/testsuite/g++.target/i386/pr102639.C @@ -0,0 +1,19 @@ +/* PR target/102639 */ +/* { dg-do compile } */ +/* { dg-options "-O2 -std=c++14 -mavx512fp16" } */ +/* { dg-final { scan-assembler-times "vminsh" 1 } } */ + +typedef _Float16 v16hf __attribute__((vector_size(2))); +v16hf vcond_v16hfv16hfge_b, vcond_v16hfv16hfge_c, vcond_v16hfv16hfge_d, + __attribute__vcond_v16hfv16hfge_a; +v16hf __attribute__vcond_v16hfv16hfge() { + return __attribute__vcond_v16hfv16hfge_a >= vcond_v16hfv16hfge_b + ? vcond_v16hfv16hfge_c + : vcond_v16hfv16hfge_d; +} + +v16hf __attribute__vcond_v16hfv16hfmax() { + return __attribute__vcond_v16hfv16hfge_a < vcond_v16hfv16hfge_b + ? __attribute__vcond_v16hfv16hfge_a + : vcond_v16hfv16hfge_b; +} diff --git a/gcc/testsuite/gcc.c-torture/compile/pr100316.c b/gcc/testsuite/gcc.c-torture/compile/pr100316.c new file mode 100644 index 0000000..38eca86 --- /dev/null +++ b/gcc/testsuite/gcc.c-torture/compile/pr100316.c @@ -0,0 +1,18 @@ +void foo(){ + __builtin___clear_cache(0, 0); +} + +void foo1(){ + __builtin___clear_cache((void*)0, (void*)0); +} + +void foo2(){ + void *yy = 0; + __builtin___clear_cache(yy, yy); +} + +void foo3(){ + void *yy = (void*)0x1000; + __builtin___clear_cache(yy, yy); +} + diff --git a/gcc/testsuite/gcc.c-torture/execute/bitfld-10.c b/gcc/testsuite/gcc.c-torture/execute/bitfld-10.c new file mode 100644 index 0000000..bdbf573 --- /dev/null +++ b/gcc/testsuite/gcc.c-torture/execute/bitfld-10.c @@ -0,0 +1,24 @@ +/* PR tree-optimization/102622 */ +/* Wrong code introduced due to phi-opt + introducing undefined signed interger overflow + with one bit signed integer negation. */ + +struct f{signed t:1;}; +int g(struct f *a, int t) __attribute__((noipa)); +int g(struct f *a, int t) +{ + if (t) + a->t = -1; + else + a->t = 0; + int t1 = a->t; + if (t1) return 1; + return t1; +} + +int main(void) +{ + struct f a; + if (!g(&a, 1)) __builtin_abort(); + return 0; +} diff --git a/gcc/testsuite/gcc.dg/Warray-bounds-48-novec.c b/gcc/testsuite/gcc.dg/Warray-bounds-48-novec.c new file mode 100644 index 0000000..da179a2 --- /dev/null +++ b/gcc/testsuite/gcc.dg/Warray-bounds-48-novec.c @@ -0,0 +1,364 @@ +/* PR middle-end/91647 - missing -Warray-bounds accessing a zero-length array + of a declared object + { dg-do "compile" } + { dg-options "-O2 -Wall -fno-tree-vectorize" } + { dg-require-effective-target alloca } */ + +typedef __INT16_TYPE__ int16_t; +typedef __INT32_TYPE__ int32_t; + +void sink (void*); + +/* Exercise a true flexible member. */ + +struct AX +{ + int32_t n; + int16_t ax[]; // { dg-message "while referencing 'ax'" "member" } +}; + +static void warn_ax_local (struct AX *p) +{ + p->ax[0] = 0; // { dg-warning "\\\[-Warray-bounds" } + p->ax[1] = 1; // { dg-warning "\\\[-Warray-bounds" } +} + +static void nowarn_ax_extern (struct AX *p) +{ + p->ax[0] = 0; p->ax[99] = 99; p->ax[999] = 999; p->ax[9999] = 9999; +} + +static void warn_ax_local_buf (struct AX *p) +{ + p->ax[0] = 4; p->ax[1] = 5; + + p->ax[2] = 6; // { dg-warning "\\\[-Warray-bounds" } + p->ax[3] = 7; // { dg-warning "\\\[-Warray-bounds" } + p->ax[4] = 8; // { dg-warning "\\\[-Warray-bounds" } +} + +static void warn_ax_extern_buf (struct AX *p) +{ + p->ax[0] = 9; p->ax[1] = 10; p->ax[2] = 11; + + p->ax[3] = 12; // { dg-warning "\\\[-Warray-bounds" } + p->ax[4] = 13; // { dg-warning "\\\[-Warray-bounds" } + p->ax[5] = 14; // { dg-warning "\\\[-Warray-bounds" } +} + +static void nowarn_ax_extern_bufx (struct AX *p) +{ + p->ax[0] = 0; p->ax[99] = 99; p->ax[999] = 999; p->ax[9999] = 9999; +} + +static void nowarn_ax_ref (struct AX *p) +{ + p->ax[0] = 0; p->ax[99] = 99; p->ax[999] = 999; p->ax[9999] = 9999; +} + +void test_ax (struct AX *p, unsigned n) +{ + { + struct AX sax; // { dg-message "defined here" "struct definition" } + warn_ax_local (&sax); + sink (&sax); + } + + { + extern + struct AX xsax; + nowarn_ax_extern (&xsax); + sink (&xsax); + } + + { + /* Verify out-of-bounds access to the local BUF is diagnosed. */ + char ax_buf_p2[sizeof (struct AX) + 2 * sizeof (int16_t)]; + warn_ax_local_buf ((struct AX*) ax_buf_p2); + sink (ax_buf_p2); + } + + { + /* Verify out-of-bounds access to the extern BUF with a known + bound is diagnosed. */ + extern char ax_buf_p3[sizeof (struct AX) + 3 * sizeof (int16_t)]; + warn_ax_extern_buf ((struct AX*) ax_buf_p3); + sink (ax_buf_p3); + } + + { + /* Verify that accesses to BUFX with an unknown bound are not + diagnosed. */ + extern char bufx[]; + nowarn_ax_extern_bufx ((struct AX*) bufx); + sink (bufx); + } + + { + /* Verify that accesses to BUFN with a runtime bound are not + diagnosed. */ + char bufn[n]; + nowarn_ax_extern_bufx ((struct AX*) bufn); + sink (bufn); + } + + nowarn_ax_ref (p); +} + + +/* Exercise a zero-length trailing member array. It's the same as above + except that extern declarations with no definitions are considered to + have zero elements (they can't be initialized to have any). */ + +struct A0 +{ + int32_t n; + int16_t a0[0]; // { dg-message "while referencing 'a0'" "member" } +}; + +static void warn_a0_local (struct A0 *p) +{ + p->a0[0] = 0; // { dg-warning "\\\[-Warray-bounds" } + p->a0[1] = 1; // { dg-warning "\\\[-Warray-bounds" } +} + +static void warn_a0_extern (struct A0 *p) +{ + p->a0[0] = 2; // { dg-warning "\\\[-Warray-bounds" } + p->a0[1] = 3; // { dg-warning "\\\[-Warray-bounds" } +} + +static void warn_a0_local_buf (struct A0 *p) +{ + p->a0[0] = 4; p->a0[1] = 5; + + p->a0[2] = 6; // { dg-warning "\\\[-Warray-bounds" } + p->a0[3] = 7; // { dg-warning "\\\[-Warray-bounds" } + p->a0[4] = 8; // { dg-warning "\\\[-Warray-bounds" } +} + +static void warn_a0_extern_buf (struct A0 *p) +{ + p->a0[0] = 9; p->a0[1] = 10; p->a0[2] = 11; + + p->a0[3] = 12; // { dg-warning "\\\[-Warray-bounds" } + p->a0[4] = 13; // { dg-warning "\\\[-Warray-bounds" } + p->a0[5] = 14; // { dg-warning "\\\[-Warray-bounds" } +} + +static void nowarn_a0_extern_bufx (struct A0 *p) +{ + p->a0[0] = 0; p->a0[99] = 99; p->a0[999] = 999; p->a0[9999] = 9999; +} + +static void nowarn_a0_ref (struct A0 *p) +{ + p->a0[0] = 0; p->a0[99] = 99; p->a0[999] = 999; p->a0[9999] = 9999; +} + +void test_a0 (struct A0 *p, unsigned n) +{ + { + struct A0 sa0; // { dg-message "defined here" "struct definition" } + warn_a0_local (&sa0); + sink (&sa0); + } + + { + extern + struct A0 xsa0; // { dg-message "defined here" "struct definition" } + warn_a0_extern (&xsa0); + sink (&xsa0); + } + + { + /* Verify out-of-bounds access to the local BUF is diagnosed. */ + char a0_buf_p2[sizeof (struct A0) + 2 * sizeof (int16_t)]; + warn_a0_local_buf ((struct A0*) a0_buf_p2); + sink (a0_buf_p2); + } + + { + /* Verify out-of-bounds access to the extern BUF with a known + bound is diagnosed. */ + extern char a0_buf_p3[sizeof (struct A0) + 3 * sizeof (int16_t)]; + warn_a0_extern_buf ((struct A0*) a0_buf_p3); + sink (a0_buf_p3); + } + + { + /* Verify that accesses to BUFX with an unknown bound are not + diagnosed. */ + extern char bufx[]; + nowarn_a0_extern_bufx ((struct A0*) bufx); + sink (bufx); + } + + { + /* Verify that accesses to BUFN with a runtime bound are not + diagnosed. */ + char bufn[n]; + nowarn_a0_extern_bufx ((struct A0*) bufn); + sink (bufn); + } + + nowarn_a0_ref (p); +} + + +/* Exercise a one-element trailing member array. It's the same as above + except that it has exactly one element. */ + +struct A1 +{ + int32_t n; + int16_t a1[1]; // { dg-message "while referencing 'a1'" } +}; + +static void warn_a1_local_noinit (struct A1 *p) +{ + p->a1[0] = 0; + p->a1[1] = 1; // { dg-warning "\\\[-Warray-bounds" } + p->a1[2] = 2; // { dg-warning "\\\[-Warray-bounds" } +} + +static void warn_a1_extern (struct A1 *p) +{ + p->a1[0] = 0; + p->a1[1] = 1; // { dg-warning "\\\[-Warray-bounds" } + p->a1[2] = 2; // { dg-warning "\\\[-Warray-bounds" } +} + +static void warn_a1_init (struct A1 *p) +{ + p->a1[0] = 0; + p->a1[1] = 1; // { dg-warning "\\\[-Warray-bounds" } + p->a1[2] = 2; // { dg-warning "\\\[-Warray-bounds" } +} + +static void warn_a1_local_buf (struct A1 *p) +{ + p->a1[0] = 0; p->a1[1] = 1; p->a1[2] = 2; p->a1[3] = 3; + + p->a1[4] = 4; // { dg-warning "\\\[-Warray-bounds" } +} + +static void warn_a1_extern_buf (struct A1 *p) +{ + p->a1[0] = 0; p->a1[1] = 1; p->a1[2] = 2; p->a1[3] = 3; p->a1[4] = 4; + + p->a1[5] = 5; // { dg-warning "\\\[-Warray-bounds" } +} + +static void nowarn_a1_extern_bufx (struct A1 *p) +{ + p->a1[0] = 0; p->a1[99] = 99; p->a1[999] = 999; p->a1[9999] = 9999; +} + +static void nowarn_a1_ref (struct A1 *p) +{ + p->a1[0] = 0; p->a1[99] = 99; p->a1[999] = 999; p->a1[9999] = 9999; +} + +void test_a1 (struct A1 *p, unsigned n) +{ + { + struct A1 a1; + warn_a1_local_noinit (&a1); + sink (&a1); + } + + { + extern struct A1 a1x; + warn_a1_extern (&a1x); + sink (&a1x); +} + { + struct A1 a1 = { 0, { 1 } }; + warn_a1_init (&a1); + sink (&a1); + } + + { + /* Verify out-of-bounds access to the local BUF is diagnosed. */ + char buf_p2[sizeof (struct A1) + 2 * sizeof (int16_t)]; + warn_a1_local_buf ((struct A1*) buf_p2); + sink (buf_p2); + } + + { + /* Verify out-of-bounds access to the extern BUF with a known + bound is diagnosed. */ + extern char a1_buf_p3[sizeof (struct A1) + 3 * sizeof (int16_t)]; + warn_a1_extern_buf ((struct A1*) a1_buf_p3); + sink (a1_buf_p3); + } + + { + /* Verify that accesses to BUFX with an unknown bound are not + diagnosed. */ + extern char bufx[]; + nowarn_a1_extern_bufx ((struct A1*) bufx); + sink (bufx); + } + + { + /* Verify that accesses to BUFN with a runtime bound are not + diagnosed. */ + char bufn[n]; + nowarn_a1_extern_bufx ((struct A1*) bufn); + sink (bufn); + } + + nowarn_a1_ref (p); +} + + +/* Exercise a two-element trailing member array. It's treated + the same as an interior array member. */ + +struct A2 +{ + int32_t n; + int16_t a2[2]; // { dg-message "while referencing 'a2'" } +}; + +static void warn_a2_noinit (struct A2 *p) +{ + p->a2[0] = 0; p->a2[1] = 1; + + p->a2[2] = 2; // { dg-warning "\\\[-Warray-bounds" } +} + +static void warn_a2_init (struct A2 *p) +{ + p->a2[0] = 0; p->a2[1] = 1; + + p->a2[2] = 2; // { dg-warning "\\\[-Warray-bounds" } + p->a2[9] = 9; // { dg-warning "\\\[-Warray-bounds" } +} + +static void warn_a2_ref (struct A2 *p) +{ + p->a2[0] = 0; p->a2[1] = 1; + + p->a2[2] = 2; // { dg-warning "\\\[-Warray-bounds" } + p->a2[9] = 9; // { dg-warning "\\\[-Warray-bounds" } +} + +void test_a2 (struct A2 *p) +{ + { + struct A2 a2; + warn_a2_noinit (&a2); + sink (&a2); + } + + { + struct A2 a2 = { 0, { 1, 2 } }; + warn_a2_init (&a2); + sink (&a2); + } + + warn_a2_ref (p); +} diff --git a/gcc/testsuite/gcc.dg/Warray-bounds-48.c b/gcc/testsuite/gcc.dg/Warray-bounds-48.c index 13373d1..19b7634c 100644 --- a/gcc/testsuite/gcc.dg/Warray-bounds-48.c +++ b/gcc/testsuite/gcc.dg/Warray-bounds-48.c @@ -30,7 +30,7 @@ static void nowarn_ax_extern (struct AX *p) static void warn_ax_local_buf (struct AX *p) { - p->ax[0] = 4; p->ax[1] = 5; + p->ax[0] = 4; p->ax[1] = 5; // { dg-warning "\\\[-Wstringop-overflow" "pr102706" { target { vect_slp_v2hi_store && { ! vect_slp_v4hi_store } } } } p->ax[2] = 6; // { dg-warning "\\\[-Warray-bounds" } p->ax[3] = 7; // { dg-warning "\\\[-Warray-bounds" } @@ -130,7 +130,7 @@ static void warn_a0_extern (struct A0 *p) static void warn_a0_local_buf (struct A0 *p) { - p->a0[0] = 4; p->a0[1] = 5; + p->a0[0] = 4; p->a0[1] = 5; // { dg-warning "\\\[-Wstringop-overflow" "pr102706" { target { vect_slp_v2hi_store && { ! vect_slp_v4hi_store } } } } p->a0[2] = 6; // { dg-warning "\\\[-Warray-bounds" } p->a0[3] = 7; // { dg-warning "\\\[-Warray-bounds" } diff --git a/gcc/testsuite/gcc.dg/Warray-bounds-51-novec.c b/gcc/testsuite/gcc.dg/Warray-bounds-51-novec.c new file mode 100644 index 0000000..ef8056d --- /dev/null +++ b/gcc/testsuite/gcc.dg/Warray-bounds-51-novec.c @@ -0,0 +1,21 @@ +/* PR middle-end/92333 - missing variable name referencing VLA in warnings + PR middle-end/82608 - missing -Warray-bounds on an out-of-bounds VLA index + { dg-do compile } + { dg-options "-O2 -Wall -fno-tree-vectorize" } */ + +void sink (void*); + +void test_struct_char_vla_location (void) +{ + unsigned nelts = 7; + + struct { + char cvla[nelts]; // { dg-message "declared here|while referencing" } + } s; + + s.cvla[0] = __LINE__; + s.cvla[nelts - 1] = 0; + s.cvla[nelts] = 0; // { dg-warning "\\\[-Warray-bounds" } + + sink (&s); +} diff --git a/gcc/testsuite/gcc.dg/Warray-bounds-51.c b/gcc/testsuite/gcc.dg/Warray-bounds-51.c index b0b8bdb..8b589f3 100644 --- a/gcc/testsuite/gcc.dg/Warray-bounds-51.c +++ b/gcc/testsuite/gcc.dg/Warray-bounds-51.c @@ -1,7 +1,8 @@ /* PR middle-end/92333 - missing variable name referencing VLA in warnings PR middle-end/82608 - missing -Warray-bounds on an out-of-bounds VLA index { dg-do compile } - { dg-options "-O2 -Wall" } */ + { dg-options "-O2 -Wall" } + { dg-additional-options "-mtune=generic" { target { i?86-*-* x86_64-*-* } } } */ void sink (void*); @@ -38,7 +39,7 @@ void test_struct_char_vla_location (void) } s; s.cvla[0] = __LINE__; - s.cvla[nelts - 1] = 0; // { dg-warning "\\\[-Wstringop-overflow" { target { i?86-*-* x86_64-*-* } } } + s.cvla[nelts - 1] = 0; // { dg-warning "\\\[-Wstringop-overflow" "pr102706" { target { vect_slp_v2qi_store } } } s.cvla[nelts] = 0; // { dg-warning "\\\[-Warray-bounds" } sink (&s); diff --git a/gcc/testsuite/gcc.dg/Warray-bounds-87.c b/gcc/testsuite/gcc.dg/Warray-bounds-87.c index a49874d..a545780 100644 --- a/gcc/testsuite/gcc.dg/Warray-bounds-87.c +++ b/gcc/testsuite/gcc.dg/Warray-bounds-87.c @@ -33,7 +33,7 @@ static unsigned int h (int i, int j) case 9: return j; case 10: - return a[i]; // { dg-bogus "-Warray-bounds" "pr101671" { xfail *-*-* } } + return a[i]; // { dg-bogus "-Warray-bounds" "pr101671" } } return 0; } diff --git a/gcc/testsuite/gcc.dg/Warray-bounds-90.c b/gcc/testsuite/gcc.dg/Warray-bounds-90.c new file mode 100644 index 0000000..1ff6077 --- /dev/null +++ b/gcc/testsuite/gcc.dg/Warray-bounds-90.c @@ -0,0 +1,147 @@ +/* PR middle-end/102453 - buffer overflow by atomic built-ins not diagnosed + Verify that out-of-bounds accesses by atomic functions are diagnosed. + { dg-do compile } + { dg-options "-O2 -Wall -ftrack-macro-expansion=0" } */ + +#ifndef __cplusplus +# define bool _Bool +#endif + +#define load __atomic_load +#define store __atomic_store +#define add_fetch __atomic_add_fetch +#define sub_fetch __atomic_sub_fetch +#define and_fetch __atomic_and_fetch +#define or_fetch __atomic_or_fetch +#define xor_fetch __atomic_xor_fetch +#define nand_fetch __atomic_nand_fetch + +typedef __SIZE_TYPE__ size_t; + +void sink (void*, ...); +#define sink(...) sink (0, __VA_ARGS__) + +extern _Bool eb; +extern char ec; +extern short int esi; +extern int ei; +extern long int eli; +extern long long int elli; + +extern const _Bool ecb; +extern const char ecc; +extern const short int ecsi; +extern const int eci; +extern const long int ecli; +extern const long long int eclli; + +extern _Atomic _Bool eab; +extern _Atomic char eac; +extern _Atomic short int easi; +extern _Atomic int eai; +extern _Atomic long int eali; +extern _Atomic long long int ealli; + +extern _Atomic const _Bool eacb; +extern _Atomic const char eacc; +extern _Atomic const short int eacsi; +extern _Atomic const int eaci; +extern _Atomic const long int eacli; +extern _Atomic const long long int eaclli; + + +void nowarn_atomic_load (void) +{ + load (&eacb, &eb, 0); + load (&eacc, &ec, 0); + load (&eacsi, &esi, 0); + load (&eaci, &ei, 0); + load (&eacli, &eli, 0); + load (&eaclli, &elli, 0); +} + + +void warn_atomic_load_note (void) +{ + int i; // { dg-message "'i'" } + + int *pi = (int*)((char*)&i + 1); + load (&eaci, pi, 0); // { dg-warning "-Warray-bounds" } + sink (&i); + + pi = (int*)((char*)&i + 2); + load (&eaci, pi, 0); // { dg-warning "-Warray-bounds" } + sink (&i); + + pi = &i + 1; + load (&eaci, pi, 0); // { dg-warning "-Warray-bounds" } + sink (&i); +} + + +void warn_atomic_load (void) +{ + bool *pb = &eb + 1; + load (&eacb, pb, 0); // { dg-warning "-Warray-bounds" } + + char *pc = &ec + 1; + load (&eacc, pc, 0); // { dg-warning "-Warray-bounds" } + + short *psi = (short*)((char*)&esi + 1); + load (&eacsi, psi, 0); // { dg-warning "-Warray-bounds" } + psi = (short*)((char*)&esi + 2); + load (&eacsi, psi, 0); // { dg-warning "-Warray-bounds" } + + int *pi = (int*)((char*)&ei + 1); + load (&eaci, pi, 0); // { dg-warning "-Warray-bounds" } + pi = (int*)((char*)&ei + 2); + load (&eaci, pi, 0); // { dg-warning "-Warray-bounds" } + pi = (int*)((char*)&ei + sizeof ei); + load (&eaci, pi, 0); // { dg-warning "-Warray-bounds" } + + long *pli = (long*)((char*)&eli + 1); + load (&eacli, pli, 0); // { dg-warning "-Warray-bounds" } + pli = (long*)((char*)&eli + 1); + load (&eacli, pli, 0); // { dg-warning "-Warray-bounds" } + pli = &eli + 1; + load (&eacli, pli, 0); // { dg-warning "-Warray-bounds" } + + long long *plli = (long long*)((char*)&elli + 1); + load (&eaclli, plli, 0); // { dg-warning "-Warray-bounds" } + plli = (long long*)((char*)&elli + 1); + load (&eaclli, plli, 0); // { dg-warning "-Warray-bounds" } + plli = &elli + 1; + load (&eaclli, plli, 0); // { dg-warning "-Warray-bounds" } +} + + +void warn_atomic_store (void) +{ + const bool *pb = &eb + 1; + store (&eab, pb, 0); // { dg-warning "-Warray-bounds" } + + const char *pc = &ec + 1; + store (&eac, pc, 0); // { dg-warning "-Warray-bounds" } + + const short *psi = (const short*)((const char*)&ecsi + 1); + store (&easi, psi, 0); // { dg-warning "-Warray-bounds" } + psi = (const short*)((const char*)&esi + 2); + store (&easi, psi, 0); // { dg-warning "-Warray-bounds" } + + const int *pi = (const int*)((const char*)&eci + 1); + store (&eai, pi, 0); // { dg-warning "-Warray-bounds" } + pi = (const int*)((const char*)&ei + 2); + store (&eai, pi, 0); // { dg-warning "-Warray-bounds" } + pi = (const int*)((const char*)&ei + sizeof ei); + store (&eai, pi, 0); // { dg-warning "-Warray-bounds" } + + const long *pli = (const long*)((const char*)&eli + 1); + store (&eali, pli, 0); // { dg-warning "-Warray-bounds" } + pli = (const long*)((const char*)&eli + sizeof (eli)); + store (&eali, pli, 0); // { dg-warning "-Warray-bounds" } + + const long long *plli = (const long long*)((const char*)&elli + 1); + store (&ealli, plli, 0); // { dg-warning "-Warray-bounds" } + plli = (const long long*)((const char*)&elli + sizeof elli); + store (&ealli, plli, 0); // { dg-warning "-Warray-bounds" } +} diff --git a/gcc/testsuite/gcc.dg/Warray-parameter-3-novec.c b/gcc/testsuite/gcc.dg/Warray-parameter-3-novec.c new file mode 100644 index 0000000..5089d55 --- /dev/null +++ b/gcc/testsuite/gcc.dg/Warray-parameter-3-novec.c @@ -0,0 +1,16 @@ +/* PR c/50584 - No warning for passing small array to C99 static array + declarator + { dg-do compile } + { dg-options "-Wall -Warray-parameter=1" } */ + +/* Also verify that -Warray-bounds doesn't trigger for ordinary array + parameters... */ +#pragma GCC optimize ("2,no-tree-vectorize") + +/* ...but does for static arrays. */ +__attribute__ ((noipa)) void +gcas3 (char a[static 3]) +{ + a[0] = 0; a[1] = 1; a[2] = 2; + a[3] = 3; // { dg-warning "\\\[-Warray-bounds" } +} diff --git a/gcc/testsuite/gcc.dg/Warray-parameter-3.c b/gcc/testsuite/gcc.dg/Warray-parameter-3.c index e2c47e1..b6ed8da 100644 --- a/gcc/testsuite/gcc.dg/Warray-parameter-3.c +++ b/gcc/testsuite/gcc.dg/Warray-parameter-3.c @@ -77,7 +77,7 @@ gia3 (int a[3]) __attribute__ ((noipa)) void gcas3 (char a[static 3]) { - a[0] = 0; a[1] = 1; a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" { target { i?86-*-* x86_64-*-* } } } + a[0] = 0; a[1] = 1; a[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" "pr102706" { target { vect_slp_v4qi_store } } } a[3] = 3; // { dg-warning "\\\[-Warray-bounds" } } diff --git a/gcc/testsuite/gcc.dg/Wrestrict-23.c b/gcc/testsuite/gcc.dg/Wrestrict-23.c new file mode 100644 index 0000000..c7a828b --- /dev/null +++ b/gcc/testsuite/gcc.dg/Wrestrict-23.c @@ -0,0 +1,146 @@ +/* PR tree-optimization/102238 - missing -Wrestrict on sprintf formatting + a struct member into enclosing object + { dg-do compile } + { dg-options "-O2 -Wall -Wno-format-overflow" } */ + +extern int sprintf (char*, const char*, ...); + +extern void sink (void*, ...); + +struct A +{ + char a[4]; +}; + +struct B +{ + struct A a1, a2; +}; + +extern struct B eb; + +enum { B_a2_a_off = __builtin_offsetof (struct B, a2.a) }; + + +void test_warn_src_decl_plus (void) +{ + { + char *s = (char*)&eb + B_a2_a_off; + char *d = eb.a2.a; + sprintf (d, "%s", s); // { dg-warning "overlaps" } + } + + { + // If strlen (s) > 0 there is overlap with a[1]. + char *s = (char*)&eb + B_a2_a_off + 1; + char *d = eb.a2.a; + sprintf (d, "%s", s); // { dg-warning "may overlap" } + } + + { + // strlen (s) must be at most 1 so there can be no overlap with a. + char *s = (char*)&eb + B_a2_a_off + 2; + char *d = eb.a2.a; + sprintf (d, "%s", s); // { dg-bogus "-Wrestrict" } + } + + { + // strlen (s) must be at most 0 so there can be no overlap with a. + char *s = (char*)&eb + B_a2_a_off + 3; + char *d = eb.a2.a; + sprintf (d, "%s", s); // { dg-bogus "-Wrestrict" } + } +} + + +void test_warn_src_ptr_plus (struct B *p) +{ + { + char *s = (char*)p + B_a2_a_off; + char *d = p->a2.a; + sprintf (d, "%s", s); // { dg-warning "overlaps" } + } + + { + // If strlen (s) > 0 there is overlap with a[1]. + char *s = (char*)p + B_a2_a_off + 1; + char *d = p->a2.a; + sprintf (d, "%s", s); // { dg-warning "may overlap" } + } + + { + // strlen (s) must be at most 1 so there can be no overlap with a. + char *s = (char*)p + B_a2_a_off + 2; + char *d = p->a2.a; + sprintf (d, "%s", s); // { dg-bogus "-Wrestrict" } + } + + { + // strlen (s) must be at most 0 so there can be no overlap with a. + char *s = (char*)p + B_a2_a_off + 3; + char *d = p->a2.a; + sprintf (d, "%s", s); // { dg-bogus "-Wrestrict" } + } +} + + +void test_warn_dst_decl_plus (void) +{ + { + char *s = eb.a2.a; + char *d = (char*)&eb + B_a2_a_off; + sprintf (d, "%s", s); // { dg-warning "overlaps" } + } + + { + // If strlen (a) > 0 there is overlap with a[1]. + char *s = eb.a2.a; + char *d = (char*)&eb + B_a2_a_off + 1; + sprintf (d, "%s", s); // { dg-warning "may overlap" } + } + + { + // If strlen (a) > 1 there is overlap with a[2]. + char *s = eb.a2.a; + char *d = (char*)&eb + B_a2_a_off + 2; + sprintf (d, "%s", s); // { dg-warning "may overlap" } + } + + { + // If strlen (a) > 2 there is overlap with a[3]. + char *s = eb.a2.a; + char *d = (char*)&eb + B_a2_a_off + 3; + sprintf (d, "%s", s); // { dg-warning "may overlap" } + } +} + + +void test_warn_dst_ptr_plus (struct B *p) +{ + { + char *s = p->a2.a; + char *d = (char*)p + B_a2_a_off; + sprintf (d, "%s", s); // { dg-warning "overlaps" } + } + + { + // If strlen (a) > 0 there is overlap with a[1]. + char *s = p->a2.a; + char *d = (char*)p + B_a2_a_off + 1; + sprintf (d, "%s", s); // { dg-warning "may overlap" } + } + + { + // If strlen (a) > 1 there is overlap with a[2]. + char *s = p->a2.a; + char *d = (char*)p + B_a2_a_off + 2; + sprintf (d, "%s", s); // { dg-warning "may overlap" } + } + + { + // If strlen (a) > 2 there is overlap with a[3]. + char *s = p->a2.a; + char *d = (char*)p + B_a2_a_off + 3; + sprintf (d, "%s", s); // { dg-warning "may overlap" } + } +} diff --git a/gcc/testsuite/gcc.dg/Wstringop-overflow-14-novec.c b/gcc/testsuite/gcc.dg/Wstringop-overflow-14-novec.c new file mode 100644 index 0000000..de39eaa --- /dev/null +++ b/gcc/testsuite/gcc.dg/Wstringop-overflow-14-novec.c @@ -0,0 +1,16 @@ +/* Test to verify that past-the-end multibyte writes via lvalues of wider + types than char are diagnosed. + { dg-do compile } + { dg-require-effective-target int32plus } + { dg-options "-O2 -fno-tree-vectorize -Wall -Wno-array-bounds" } */ + +typedef __INT16_TYPE__ int16_t; + +char a4[4], a8[8], a16[16]; + +void test_int16 (void) +{ + char *p = a4 + 1; + *(int16_t*)p = 0; + *(int16_t*)(p + 2) = 0; // { dg-warning "writing 2 bytes into a region of size 1" } +} diff --git a/gcc/testsuite/gcc.dg/Wstringop-overflow-14.c b/gcc/testsuite/gcc.dg/Wstringop-overflow-14.c index b648f5b..c4a3f05 100644 --- a/gcc/testsuite/gcc.dg/Wstringop-overflow-14.c +++ b/gcc/testsuite/gcc.dg/Wstringop-overflow-14.c @@ -2,7 +2,8 @@ types than char are diagnosed. { dg-do compile } { dg-require-effective-target int32plus } - { dg-options "-O2 -Wall -Wno-array-bounds" } */ + { dg-options "-O2 -Wall -Wno-array-bounds" } + { dg-additional-options "-mtune=generic" { target { i?86-*-* x86_64-*-* } } } */ typedef __INT16_TYPE__ int16_t; typedef __INT32_TYPE__ int32_t; @@ -35,8 +36,8 @@ void test_memcpy_cond (int i) void test_int16 (void) { char *p = a4 + 1; - *(int16_t*)p = 0; // { dg-warning "writing 4 bytes into a region of size 3" { target { i?86-*-* x86_64-*-* } } } - *(int16_t*)(p + 2) = 0; // { dg-warning "writing 2 bytes into a region of size 1" "" { xfail { i?86-*-* x86_64-*-* } } } + *(int16_t*)p = 0; // { dg-warning "writing 4 bytes into a region of size 3" "pr102706" { target { vect_slp_v2hi_store } } } + *(int16_t*)(p + 2) = 0; // { dg-warning "writing 2 bytes into a region of size 1" "pr102706" { xfail { vect_slp_v2hi_store } } } } diff --git a/gcc/testsuite/gcc.dg/Wstringop-overflow-21-novec.c b/gcc/testsuite/gcc.dg/Wstringop-overflow-21-novec.c new file mode 100644 index 0000000..6f83548 --- /dev/null +++ b/gcc/testsuite/gcc.dg/Wstringop-overflow-21-novec.c @@ -0,0 +1,34 @@ +/* PR middle-end/92312 - bogus -Wstringop-overflow storing into a trailing + array backed by larger buffer + { dg-do compile } + { dg-options "-O2 -fno-tree-vectorize -Wall -Wno-array-bounds" } */ + +struct S0 { char a, b[0]; }; + +void sink (void*); + +void test_store_zero_length (int i) +{ + char a[3]; + struct S0 *p = (struct S0*)a; + p->a = 0; + p->b[0] = 0; + p->b[1] = 1; // { dg-bogus "\\\[-Wstringop-overflow" } + p->b[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" } + p->b[i] = 2; + sink (p); +} + +struct Sx { char a, b[]; }; + +void test_store_flexarray (int i) +{ + char a[3]; + struct Sx *p = (struct Sx*)a; + p->a = 0; + p->b[0] = 0; + p->b[1] = 1; // { dg-bogus "\\\[-Wstringop-overflow" } + p->b[2] = 1; // { dg-warning "\\\[-Wstringop-overflow" } + p->b[i] = 2; + sink (p); +} diff --git a/gcc/testsuite/gcc.dg/Wstringop-overflow-21.c b/gcc/testsuite/gcc.dg/Wstringop-overflow-21.c index e88f7b4..3fccfc9 100644 --- a/gcc/testsuite/gcc.dg/Wstringop-overflow-21.c +++ b/gcc/testsuite/gcc.dg/Wstringop-overflow-21.c @@ -23,10 +23,10 @@ void test_store_zero_length (int i) { char a[3]; struct S0 *p = (struct S0*)a; - p->a = 0; // { dg-warning "\\\[-Wstringop-overflow" { target { i?86-*-* x86_64-*-* } } } + p->a = 0; // { dg-warning "\\\[-Wstringop-overflow" "pr102706" { target { vect_slp_v4qi_store } } } p->b[0] = 0; p->b[1] = 1; // { dg-bogus "\\\[-Wstringop-overflow" } - p->b[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" "" { xfail { i?86-*-* x86_64-*-* } } } + p->b[2] = 2; // { dg-warning "\\\[-Wstringop-overflow" "pr102706" { xfail { vect_slp_v4qi_store } } } p->b[i] = 2; sink (p); } @@ -50,10 +50,10 @@ void test_store_flexarray (int i) { char a[3]; struct Sx *p = (struct Sx*)a; - p->a = 0; // { dg-warning "\\\[-Wstringop-overflow" { target { i?86-*-* x86_64-*-* } } } + p->a = 0; // { dg-warning "\\\[-Wstringop-overflow" "pr102706" { target { vect_slp_v4qi_store } } } p->b[0] = 0; p->b[1] = 1; // { dg-bogus "\\\[-Wstringop-overflow" } - p->b[2] = 1; // { dg-warning "\\\[-Wstringop-overflow" "" { xfail { i?86-*-* x86_64-*-* } } } + p->b[2] = 1; // { dg-warning "\\\[-Wstringop-overflow" "pr102706" { xfail { vect_slp_v4qi_store } } } p->b[i] = 2; sink (p); } diff --git a/gcc/testsuite/gcc.dg/Wstringop-overflow-22.c b/gcc/testsuite/gcc.dg/Wstringop-overflow-22.c index 8eaaa71..764b199 100644 --- a/gcc/testsuite/gcc.dg/Wstringop-overflow-22.c +++ b/gcc/testsuite/gcc.dg/Wstringop-overflow-22.c @@ -260,13 +260,12 @@ T (puts_unlocked, a); // { dg-warning "missing terminating nul" "puts_unlo // Exerise exec functions. T (execl, a, s, NULL); // { dg-warning "missing terminating nul" "execl" } -T (execl, a, s, NULL); // { dg-warning "missing terminating nul" "execl" } -T (execle, a, s, NULL, NULL); // { dg-warning "missing terminating nul" "execl" } -T (execlp, a, s, NULL); // { dg-warning "missing terminating nul" "execl" } +T (execle, a, s, NULL, NULL); // { dg-warning "missing terminating nul" "execle" } +T (execlp, a, s, NULL); // { dg-warning "missing terminating nul" "execlp" } -T (execv, a, &d); // { dg-warning "missing terminating nul" "execl" } -T (execve, a, &d, &d); // { dg-warning "missing terminating nul" "execl" } -T (execvp, a, &d); // { dg-warning "missing terminating nul" "execl" } +T (execv, a, &d); // { dg-warning "missing terminating nul" "execv" } +T (execve, a, &d, &d); // { dg-warning "missing terminating nul" "execve" } +T (execvp, a, &d); // { dg-warning "missing terminating nul" "execvp" } T (gettext, a); // { dg-warning "missing terminating nul" "gettext" } diff --git a/gcc/testsuite/gcc.dg/Wstringop-overflow-68.c b/gcc/testsuite/gcc.dg/Wstringop-overflow-68.c index 09df000..04e91af 100644 --- a/gcc/testsuite/gcc.dg/Wstringop-overflow-68.c +++ b/gcc/testsuite/gcc.dg/Wstringop-overflow-68.c @@ -58,11 +58,18 @@ void warn_comp_lit_zero (void) void warn_comp_lit (void) { *(AC2*)a1 = Ac2; // { dg-warning "writing 2 bytes into a region of size 1" "pr101475" { xfail *-*-* } } - *(AC4*)a2 = Ac4; // { dg-warning "writing 4 bytes into a region of size 2" "pr101475" { xfail { ! { i?86-*-* x86_64-*-* } } } } - *(AC4*)a3 = Ac4; // { dg-warning "writing 4 bytes into a region of size 3" "pr101475" { xfail { ! { i?86-*-* x86_64-*-* } } } } - *(AC8*)a4 = Ac8; // { dg-warning "writing 8 bytes into a region of size 4" "pr101475" { xfail { ! { i?86-*-* x86_64-*-* } } } } - *(AC8*)a7 = Ac8; // { dg-warning "writing 8 bytes into a region of size 7" "pr101475" { xfail { ! { i?86-*-* x86_64-*-* } } } } - *(AC16*)a15 = Ac16; // { dg-warning "writing 16 bytes into a region of size 15" "pr101475" { xfail { ! { i?86-*-* x86_64-*-* } } } } + // After vectorization, below codes are optimized to + // MEM <vector(4) char> [(char *)&a2] = { 0, 1, 2, 3 }; + // MEM <vector(4) char> [(char *)&a3] = { 0, 1, 2, 3 }; + // MEM <vector(8) char> [(char *)&a4] = { 0, 1, 2, 3, 4, 5, 6, 7 }; + // MEM <vector(8) char> [(char *)&a7] = { 0, 1, 2, 3, 4, 5, 6, 7 }; + // MEM <vector(16) char> [(char *)&a15] = { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 }; + // and warning should be expected, refer to PR102722. + *(AC4*)a2 = Ac4; // { dg-warning "writing 4 bytes into a region of size 2" "pr101475" { xfail { ! { vect_slp_v4qi_store } } } } + *(AC4*)a3 = Ac4; // { dg-warning "writing 4 bytes into a region of size 3" "pr101475" { xfail { ! { vect_slp_v4qi_store } } } } + *(AC8*)a4 = Ac8; // { dg-warning "writing 8 bytes into a region of size 4" "pr101475" { xfail { ! { vect_slp_v8qi_store } } } } + *(AC8*)a7 = Ac8; // { dg-warning "writing 8 bytes into a region of size 7" "pr101475" { xfail { ! { vect_slp_v8qi_store } } } } + *(AC16*)a15 = Ac16; // { dg-warning "writing 16 bytes into a region of size 15" "pr101475" { xfail { ! { vect_slp_v16qi_store } } } } } void warn_aggr_decl (void) diff --git a/gcc/testsuite/gcc.dg/Wstringop-overflow-76-novec.c b/gcc/testsuite/gcc.dg/Wstringop-overflow-76-novec.c new file mode 100644 index 0000000..71c643b --- /dev/null +++ b/gcc/testsuite/gcc.dg/Wstringop-overflow-76-novec.c @@ -0,0 +1,88 @@ +/* Verify warnings and notes for MAX_EXPRs involving either pointers + to distinct objects or one to a known object and the other to + an unknown one. Unlike for the same object, for unrelated objects + the expected warnings and notes are the same as for MIN_EXPR: when + the order of the objects in the address space cannot be determined + the larger of them is assumed to be used. (This is different for + distinct struct members where the order is given.) + The relational expressions are strictly invalid but that should be + diagnosed by a separate warning. + { dg-do compile } + { dg-options "-O2 -Wno-array-bounds -fno-tree-vectorize" } */ + +#define MAX(p, q) ((p) > (q) ? (p) : (q)) + +/* Verify that even for MAX_EXPR and like for MIN_EXPR, the note points + to the larger of the two objects and mentions the offset into it + (although the offset might be better included in the warning). */ +extern char a3[3]; +extern char a5[5]; // { dg-message "at offset 5 into destination object 'a5' of size 5" "note" } + +void max_a3_a5 (int i) +{ + char *p = a3 + i; + char *q = a5 + i; + + /* The relational expression below is invalid and should be diagnosed + by its own warning independently of -Wstringop-overflow. */ + char *d = MAX (p, q); + + d[2] = 0; + d[3] = 0; + d[4] = 0; + d[5] = 0; // { dg-warning "writing 1 byte into a region of size 0" } +} + + +// Same as above but with the larger array as the first MAX_EXPR operand. +extern char b4[4]; +extern char b6[6]; // { dg-message "at offset 6 into destination object 'b6' of size 6" "note" } + +void max_b6_b4 (int i) +{ + char *p = b6 + i; + char *q = b4 + i; + char *d = MAX (p, q); + + d[3] = 0; + d[4] = 0; + d[5] = 0; + d[6] = 0; // { dg-warning "writing 1 byte into a region of size 0" } +} + +struct A3_5 +{ + char a3[3]; // { dg-message "at offset 3 into destination object 'a3' of size 3" "pr??????" { xfail *-*-* } } + char a5[5]; // { dg-message "at offset 5 into destination object 'a5' of size 5" "note" } +}; + +void max_A3_A5 (int i, struct A3_5 *pa3_5) +{ + char *p = pa3_5->a3 + i; + char *q = pa3_5->a5 + i; + + char *d = MAX (p, q); + d[2] = 0; + d[3] = 0; // { dg-warning "writing 1 byte into a region of size 0" "pr??????" { xfail *-*-* } } + d[4] = 0; + d[5] = 0; // { dg-warning "writing 1 byte into a region of size 0" } +} + + +struct B4_B6 +{ + char b4[4]; + char b6[6]; // { dg-message "at offset 6 into destination object 'b6' of size 6" "note" } +}; + +void max_B6_B4 (int i, struct B4_B6 *pb4_b6) +{ + char *p = pb4_b6->b6 + i; + char *q = pb4_b6->b4 + i; + char *d = MAX (p, q); + + d[3] = 0; + d[4] = 0; + d[5] = 0; + d[6] = 0; // { dg-warning "writing 1 byte into a region of size 0" } +} diff --git a/gcc/testsuite/gcc.dg/Wstringop-overflow-76.c b/gcc/testsuite/gcc.dg/Wstringop-overflow-76.c index 30b1c9a..5246726 100644 --- a/gcc/testsuite/gcc.dg/Wstringop-overflow-76.c +++ b/gcc/testsuite/gcc.dg/Wstringop-overflow-76.c @@ -27,10 +27,10 @@ void max_a3_a5 (int i) by its own warning independently of -Wstringop-overflow. */ char *d = MAX (p, q); - d[2] = 0; // { dg-warning "writing 4 bytes into a region of size 3" { target { i?86-*-* x86_64-*-* } } } + d[2] = 0; // { dg-warning "writing 4 bytes into a region of size 3" "pr102706" { target { vect_slp_v4qi_store } } } d[3] = 0; d[4] = 0; - d[5] = 0; // { dg-warning "writing 1 byte into a region of size 0" "" { xfail { i?86-*-* x86_64-*-* } } } + d[5] = 0; // { dg-warning "writing 1 byte into a region of size 0" "pr102706" { xfail { vect_slp_v4qi_store } } } } @@ -44,10 +44,10 @@ void max_b6_b4 (int i) char *q = b4 + i; char *d = MAX (p, q); - d[3] = 0; // { dg-warning "writing 4 bytes into a region of size 3" { target { i?86-*-* x86_64-*-* } } } + d[3] = 0; // { dg-warning "writing 4 bytes into a region of size 3" "pr102706" { target { vect_slp_v4qi_store } } } d[4] = 0; d[5] = 0; - d[6] = 0; // { dg-warning "writing 1 byte into a region of size 0" "" { xfail { i?86-*-* x86_64-*-* } } } + d[6] = 0; // { dg-warning "writing 1 byte into a region of size 0" "pr102706" { xfail { vect_slp_v4qi_store } } } } @@ -82,7 +82,8 @@ void max_d8_p (char *q, int i) struct A3_5 { char a3[3]; // { dg-message "at offset 3 into destination object 'a3' of size 3" "pr??????" { xfail *-*-* } } - char a5[5]; // { dg-message "at offset 5 into destination object 'a5' of size 5" "note" { xfail { i?86-*-* x86_64-*-* } } } + // refer to pr102697 for xfail + char a5[5]; // { dg-message "at offset 5 into destination object 'a5' of size 5" "note" { xfail { vect_slp_v4qi_store } } } }; void max_A3_A5 (int i, struct A3_5 *pa3_5) @@ -95,14 +96,15 @@ void max_A3_A5 (int i, struct A3_5 *pa3_5) d[2] = 0; d[3] = 0; // { dg-warning "writing 1 byte into a region of size 0" "pr??????" { xfail *-*-* } } d[4] = 0; - d[5] = 0; // { dg-warning "writing 1 byte into a region of size 0" "" { xfail { i?86-*-* x86_64-*-* } } } + d[5] = 0; // { dg-warning "writing 1 byte into a region of size 0" "pr102697" { xfail { vect_slp_v4qi_store } } } } struct B4_B6 { char b4[4]; - char b6[6]; // { dg-message "at offset \[^a-zA-Z\n\r\]*6\[^a-zA-Z0-9\]* into destination object 'b6' of size 6" "note" { xfail { i?86-*-* x86_64-*-* } } } + // refer to pr102697 for xfail + char b6[6]; // { dg-message "at offset \[^a-zA-Z\n\r\]*6\[^a-zA-Z0-9\]* into destination object 'b6' of size 6" "note" { xfail { vect_slp_v4qi_store } } } }; void max_B6_B4 (int i, struct B4_B6 *pb4_b6) @@ -114,7 +116,7 @@ void max_B6_B4 (int i, struct B4_B6 *pb4_b6) d[3] = 0; d[4] = 0; d[5] = 0; - d[6] = 0; // { dg-warning "writing 1 byte into a region of size 0" "" { xfail { i?86-*-* x86_64-*-* } } } + d[6] = 0; // { dg-warning "writing 1 byte into a region of size 0" "pr102697" { xfail { vect_slp_v4qi_store } } } } diff --git a/gcc/testsuite/gcc.dg/Wstringop-overflow-77.c b/gcc/testsuite/gcc.dg/Wstringop-overflow-77.c new file mode 100644 index 0000000..732f568 --- /dev/null +++ b/gcc/testsuite/gcc.dg/Wstringop-overflow-77.c @@ -0,0 +1,516 @@ +/* PR middle-end/102453 - buffer overflow by atomic built-ins not diagnosed + Verify that out-of-bounds accesses by atomic functions are diagnosed with + optimization disabled. + { dg-do compile } + { dg-options "-O0 -Wall -ftrack-macro-expansion=0" } */ + +#ifndef __cplusplus +# define bool _Bool +#endif + +#define add_fetch(p, q) __atomic_add_fetch (p, q, 0) +#define sub_fetch(p, q) __atomic_sub_fetch (p, q, 0) +#define and_fetch(p, q) __atomic_and_fetch (p, q, 0) +#define or_fetch(p, q) __atomic_or_fetch (p, q, 0) +#define xor_fetch(p, q) __atomic_xor_fetch (p, q, 0) +#define nand_fetch(p, q) __atomic_nand_fetch (p, q, 0) +#define exchange(p, q, r) __atomic_exchange (p, q, r, 0) +#define exchange_n(p, n) __atomic_exchange_n (p, n, 0) +#define cmpxchg(p, q, r) __atomic_compare_exchange (p, q, r, 0, 0, 0) + +typedef __SIZE_TYPE__ size_t; + +void sink (void*, ...); +#define sink(...) sink (0, __VA_ARGS__) + +extern _Bool eb; +extern char ec; +extern short int esi; +extern int ei; +extern long int eli; +extern long long int elli; + +extern const _Bool ecb; +extern const char ecc; +extern const short int ecsi; +extern const int eci; +extern const long int ecli; +extern const long long int eclli; + +extern _Atomic _Bool eab; +extern _Atomic char eac; +extern _Atomic short int easi; +extern _Atomic int eai; +extern _Atomic long int eali; +extern _Atomic long long int ealli; + +extern _Atomic const _Bool eacb; +extern _Atomic const char eacc; +extern _Atomic const short int eacsi; +extern _Atomic const int eaci; +extern _Atomic const long int eacli; +extern _Atomic const long long int eaclli; + + +void nowarn_atomic_add_fetch (void) +{ + add_fetch (&eac, ecc); + add_fetch (&easi, esi); + add_fetch (&eai, ei); + add_fetch (&eali, eli); + add_fetch (&ealli, elli); +} + + +void warn_atomic_add_fetch (void) +{ + _Atomic char *pc = &eac + 1; + add_fetch (pc, ecc); // { dg-warning "-Wstringop-overflow" } + + _Atomic short *psi = (_Atomic short*)((char*)&easi + 1); + add_fetch (psi, esi); // { dg-warning "-Wstringop-overflow" } + psi = (_Atomic short*)((char*)&easi + 2); + add_fetch (psi, esi); // { dg-warning "-Wstringop-overflow" } + + _Atomic int *pi = (_Atomic int*)((char*)&eai + 1); + add_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + 2); + add_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + sizeof eai); + add_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + + _Atomic long *pli = (_Atomic long*)((char*)&eali + 1); + add_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + pli = (_Atomic long*)((char*)&eali + 1); + add_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + pli = &eali + 1; + add_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + + _Atomic long long *plli = (_Atomic long long*)((char*)&ealli + 1); + add_fetch (plli, elli); // { dg-warning "-Wstringop-overflow" } + plli = (_Atomic long long*)((char*)&ealli + 1); + add_fetch (plli, eali); // { dg-warning "-Wstringop-overflow" } + plli = &ealli + 1; + add_fetch (plli, elli); // { dg-warning "-Wstringop-overflow" } +} + + +void nowarn_atomic_sub_fetch (void) +{ + _Atomic char *pc = &eac; + sub_fetch (pc, ecc); + + _Atomic short *psi = &easi; + sub_fetch (psi, esi); + + _Atomic int *pi = &eai; + sub_fetch (pi, ei); + + _Atomic long *pli = &eali; + sub_fetch (pli, eli); + + _Atomic long long *plli = &ealli; + sub_fetch (plli, elli); +} + + +void warn_atomic_sub_fetch (void) +{ + _Atomic char *pc = &eac + 1; + sub_fetch (pc, ecc); // { dg-warning "-Wstringop-overflow" } + + _Atomic short *psi = (_Atomic short*)((char*)&easi + 1); + sub_fetch (psi, esi); // { dg-warning "-Wstringop-overflow" } + psi = (_Atomic short*)((char*)&easi + 2); + sub_fetch (psi, esi); // { dg-warning "-Wstringop-overflow" } + + _Atomic int *pi = (_Atomic int*)((char*)&eai + 1); + sub_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + 2); + sub_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + sizeof eai); + sub_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + + _Atomic long *pli = (_Atomic long*)((char*)&eali + 1); + sub_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + pli = (_Atomic long*)((char*)&eali + 1); + sub_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + pli = &eali + 1; + sub_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + + _Atomic long long *plli = (_Atomic long long*)((char*)&ealli + 1); + sub_fetch (plli, elli); // { dg-warning "-Wstringop-overflow" } + plli = (_Atomic long long*)((char*)&ealli + 1); + sub_fetch (plli, eali); // { dg-warning "-Wstringop-overflow" } + plli = &ealli + 1; + sub_fetch (plli, elli); // { dg-warning "-Wstringop-overflow" } +} + + +void nowarn_atomic_and_fetch (void) +{ + _Atomic char *pc = &eac; + and_fetch (pc, ecc); + + _Atomic short *psi = &easi; + and_fetch (psi, esi); + + _Atomic int *pi = &eai; + and_fetch (pi, ei); + + _Atomic long *pli = &eali; + and_fetch (pli, eli); + + _Atomic long long *plli = &ealli; + and_fetch (plli, elli); +} + + +void warn_atomic_and_fetch (void) +{ + _Atomic char *pc = &eac + 1; + and_fetch (pc, ecc); // { dg-warning "-Wstringop-overflow" } + + _Atomic short *psi = (_Atomic short*)((char*)&easi + 1); + and_fetch (psi, esi); // { dg-warning "-Wstringop-overflow" } + psi = (_Atomic short*)((char*)&easi + 2); + and_fetch (psi, esi); // { dg-warning "-Wstringop-overflow" } + + _Atomic int *pi = (_Atomic int*)((char*)&eai + 1); + and_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + 2); + and_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + sizeof eai); + and_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + + _Atomic long *pli = (_Atomic long*)((char*)&eali + 1); + and_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + pli = (_Atomic long*)((char*)&eali + 1); + and_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + pli = &eali + 1; + and_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + + _Atomic long long *plli = (_Atomic long long*)((char*)&ealli + 1); + and_fetch (plli, elli); // { dg-warning "-Wstringop-overflow" } + plli = (_Atomic long long*)((char*)&ealli + 1); + and_fetch (plli, eali); // { dg-warning "-Wstringop-overflow" } + plli = &ealli + 1; + and_fetch (plli, elli); // { dg-warning "-Wstringop-overflow" } +} + + +void nowarn_atomic_or_fetch (void) +{ + _Atomic char *pc = &eac; + or_fetch (pc, ecc); + + _Atomic short *psi = &easi; + or_fetch (psi, esi); + + _Atomic int *pi = &eai; + or_fetch (pi, ei); + + _Atomic long *pli = &eali; + or_fetch (pli, eli); + + _Atomic long long *plli = &ealli; + or_fetch (plli, elli); +} + + +void warn_atomic_or_fetch (void) +{ + _Atomic char *pc = &eac + 1; + or_fetch (pc, ecc); // { dg-warning "-Wstringop-overflow" } + + _Atomic short *psi = (_Atomic short*)((char*)&easi + 1); + or_fetch (psi, esi); // { dg-warning "-Wstringop-overflow" } + psi = (_Atomic short*)((char*)&easi + 2); + or_fetch (psi, esi); // { dg-warning "-Wstringop-overflow" } + + _Atomic int *pi = (_Atomic int*)((char*)&eai + 1); + or_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + 2); + or_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + sizeof eai); + or_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + + _Atomic long *pli = (_Atomic long*)((char*)&eali + 1); + or_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + pli = (_Atomic long*)((char*)&eali + 1); + or_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + pli = &eali + 1; + or_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + + _Atomic long long *plli = (_Atomic long long*)((char*)&ealli + 1); + or_fetch (plli, elli); // { dg-warning "-Wstringop-overflow" } + plli = (_Atomic long long*)((char*)&ealli + 1); + or_fetch (plli, eali); // { dg-warning "-Wstringop-overflow" } + plli = &ealli + 1; + or_fetch (plli, elli); // { dg-warning "-Wstringop-overflow" } +} + + +void nowarn_atomic_xor_fetch (void) +{ + _Atomic char *pc = &eac; + xor_fetch (pc, ecc); + + _Atomic short *psi = &easi; + xor_fetch (psi, esi); + + _Atomic int *pi = &eai; + xor_fetch (pi, ei); + + _Atomic long *pli = &eali; + xor_fetch (pli, eli); + + _Atomic long long *plli = &ealli; + xor_fetch (plli, elli); +} + + +void warn_atomic_xor_fetch (void) +{ + _Atomic char *pc = &eac + 1; + xor_fetch (pc, ecc); // { dg-warning "-Wstringop-overflow" } + + _Atomic short *psi = (_Atomic short*)((char*)&easi + 1); + xor_fetch (psi, esi); // { dg-warning "-Wstringop-overflow" } + psi = (_Atomic short*)((char*)&easi + 1); + xor_fetch (psi, esi); // { dg-warning "-Wstringop-overflow" } + + _Atomic int *pi = (_Atomic int*)((char*)&eai + 1); + xor_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + 2); + xor_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + sizeof eai); + xor_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + + _Atomic long *pli = (_Atomic long*)((char*)&eali + 1); + xor_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + pli = (_Atomic long*)((char*)&eali + 1); + xor_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + pli = &eali + 1; + xor_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + + _Atomic long long *plli = (_Atomic long long*)((char*)&ealli + 1); + xor_fetch (plli, elli); // { dg-warning "-Wstringop-overflow" } + plli = (_Atomic long long*)((char*)&eali + 1); + xor_fetch (plli, eali); // { dg-warning "-Wstringop-overflow" } + plli = &ealli + 1; + xor_fetch (plli, elli); // { dg-warning "-Wstringop-overflow" } +} + + +void nowarn_atomic_nand_fetch (void) +{ + _Atomic char *pc = &eac; + nand_fetch (pc, ecc); + + _Atomic short *psi = &easi; + nand_fetch (psi, esi); + + _Atomic int *pi = &eai; + nand_fetch (pi, ei); + + _Atomic long *pli = &eali; + nand_fetch (pli, eli); + + _Atomic long long *plli = &ealli; + nand_fetch (plli, elli); +} + + +void warn_atomic_nand_fetch (void) +{ + _Atomic char *pc = &eac + 1; + nand_fetch (pc, ecc); // { dg-warning "-Wstringop-overflow" } + + _Atomic short *psi = (_Atomic short*)((char*)&easi + 1); + nand_fetch (psi, esi); // { dg-warning "-Wstringop-overflow" } + psi = (_Atomic short*)((char*)&easi + 1); + nand_fetch (psi, esi); // { dg-warning "-Wstringop-overflow" } + + _Atomic int *pi = (_Atomic int*)((char*)&eai + 1); + nand_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + 2); + nand_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + sizeof eai); + nand_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + + _Atomic long *pli = (_Atomic long*)((char*)&eali + 1); + nand_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + pli = (_Atomic long*)((char*)&eali + 1); + nand_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + pli = &eali + 1; + nand_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + + _Atomic long long *plli = (_Atomic long long*)((char*)&ealli + 1); + nand_fetch (plli, elli); // { dg-warning "-Wstringop-overflow" } + plli = (_Atomic long long*)((char*)&eai + 1); + nand_fetch (plli, eali); // { dg-warning "-Wstringop-overflow" } + plli = &ealli + 1; + nand_fetch (plli, elli); // { dg-warning "-Wstringop-overflow" } +} + + +void nowarn_atomic_exchange (void) +{ + char rc; + _Atomic char *pc = &eac; + exchange (pc, &ecc, &rc); + + short rsi; + _Atomic short *psi = &easi; + exchange (psi, &esi, &rsi); + + int ri; + _Atomic int *pi = &eai; + exchange (pi, &ei, &ri); + + long rli; + _Atomic long *pli = &eali; + exchange (pli, &eli, &rli); + + long long rlli; + _Atomic long long *plli = &ealli; + exchange (plli, &elli, &rlli); + + sink (&rc, &rsi, &ri, &rli, &rlli); +} + +void warn_atomic_exchange (void) +{ + char rc; + _Atomic char *pc = &eac + 1; + exchange (pc, &ecc, &rc); // { dg-warning "-Wstringop-overflow" } + + short rsi[2]; + _Atomic short *psi = (_Atomic short*)((char*)&easi + 1); + exchange (psi, &ecsi, rsi); // { dg-warning "-Wstringop-overflow" } + psi = (_Atomic short*)((char*)&easi + 2); + exchange (psi, &ecsi, rsi + 1); // { dg-warning "-Wstringop-overflow" } + + int ri[3]; + _Atomic int *pi = (_Atomic int*)((char*)&eai + 1); + exchange (pi, &eci, ri); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + 2); + exchange (pi, &eci, ri + 1); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + sizeof eai); + exchange (pi, &eci, ri + 2); // { dg-warning "-Wstringop-overflow" } + + long rli[3]; + _Atomic long *pli = (_Atomic long*)((char*)&eali + 1); + exchange (pli, &ecli, rli); // { dg-warning "-Wstringop-overflow" } + pli = (_Atomic long*)((char*)&eali + 1); + exchange (pli, &ecli, rli + 1); // { dg-warning "-Wstringop-overflow" } + pli = &eali + 1; + exchange (pli, &ecli, rli + 2); // { dg-warning "-Wstringop-overflow" } + + long long rlli[3]; + _Atomic long long *plli = (_Atomic long long*)((char*)&ealli + 1); + exchange (plli, &eclli, rlli); // { dg-warning "-Wstringop-overflow" } + plli = (_Atomic long long*)((char*)&ealli + 1); + exchange (plli, &eclli, rlli + 1); // { dg-warning "-Wstringop-overflow" } + plli = &ealli + 1; + exchange (plli, &eclli, rlli + 2); // { dg-warning "-Wstringop-overflow" } + + sink (&rc, rsi, ri, rli, rlli); +} + + +void nowarn_atomic_exchange_n (_Atomic unsigned char *pauc, + _Atomic unsigned short *pausi, + _Atomic unsigned int *paui, + _Atomic unsigned long *pauli, + _Atomic unsigned long long *paulli) +{ + char rc = exchange_n (&eac, ecc); + short rsi = exchange_n (&easi, esi); + int ri = exchange_n (&eai, ei); + long rli = exchange_n (&eali, eli); + long long rlli = exchange_n (&ealli, elli); + + sink (rc, rsi, ri, rli, rlli); + + char ruc = exchange_n (pauc, ecc); + short rusi = exchange_n (pausi, esi); + int rui = exchange_n (paui, ei); + long ruli = exchange_n (pauli, eli); + long long rulli = exchange_n (paulli, elli); + + sink (ruc, rusi, rui, ruli, rulli); +} + + +void warn_atomic_exchange_n (void) +{ + _Atomic char *pc = &eac + 1; + char rc = exchange_n (pc, ecc); // { dg-warning "-Wstringop-overflow" } + + short rsi[2]; + _Atomic short *psi = (_Atomic short*)((char*)&easi + 1); + rsi[0] = exchange_n (psi, ecsi); // { dg-warning "-Wstringop-overflow" } + psi = (_Atomic short*)((char*)&easi + 2); + rsi[1] = exchange_n (psi, ecsi); // { dg-warning "-Wstringop-overflow" } + + int ri[3]; + _Atomic int *pi = (_Atomic int*)((char*)&eai + 1); + ri[0] = exchange_n (pi, eci); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + 2); + ri[1] = exchange_n (pi, eci); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + sizeof eai); + ri[2] = exchange_n (pi, eci); // { dg-warning "-Wstringop-overflow" } + + long rli[3]; + _Atomic long *pli = (_Atomic long*)((char*)&eali + 1); + rli[0] = exchange_n (pli, ecli); // { dg-warning "-Wstringop-overflow" } + pli = (_Atomic long*)((char*)&eali + 1); + rli[1] = exchange_n (pli, ecli); // { dg-warning "-Wstringop-overflow" } + pli = &eali + 1; + rli[2] = exchange_n (pli, ecli); // { dg-warning "-Wstringop-overflow" } + + long long rlli[3]; + _Atomic long long *plli = (_Atomic long long*)((char*)&ealli + 1); + rlli[0] = exchange_n (plli, eclli); // { dg-warning "-Wstringop-overflow" } + plli = (_Atomic long long*)((char*)&ealli + 1); + rlli[1] = exchange_n (plli, eclli); // { dg-warning "-Wstringop-overflow" } + plli = &ealli + 1; + rlli[2] = exchange_n (plli, eclli); // { dg-warning "-Wstringop-overflow" } + + sink (&rc, rsi, ri, rli, rlli); +} + + +void warn_atomic_compare_exchange (void) +{ + _Atomic char *pc = &eac + 1; + cmpxchg (pc, &ec, &ecc); // { dg-warning "-Wstringop-overflow" } + + _Atomic short *psi = (_Atomic short*)((char*)&easi + 1); + cmpxchg (psi, &esi, &ecsi); // { dg-warning "-Wstringop-overflow" } + psi = (_Atomic short*)((char*)&easi + 2); + cmpxchg (psi, &esi, &ecsi); // { dg-warning "-Wstringop-overflow" } + + _Atomic int *pi = (_Atomic int*)((char*)&eai + 1); + cmpxchg (pi, &ei, &eci); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + 2); + cmpxchg (pi, &ei, &eci); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + sizeof eai); + cmpxchg (pi, &ei, &eci); // { dg-warning "-Wstringop-overflow" } + + _Atomic long *pli = (_Atomic long*)((char*)&eali + 1); + cmpxchg (pli, &eli, &ecli); // { dg-warning "-Wstringop-overflow" } + pli = (_Atomic long*)((char*)&eali + 1); + cmpxchg (pli, &eli, &ecli); // { dg-warning "-Wstringop-overflow" } + pli = &eali + 1; + cmpxchg (pli, &eli, &ecli); // { dg-warning "-Wstringop-overflow" } + + _Atomic long long *plli = (_Atomic long long*)((char*)&ealli + 1); + cmpxchg (plli, &elli, &eclli); // { dg-warning "-Wstringop-overflow" } + plli = (_Atomic long long*)((char*)&ealli + 1); + cmpxchg (plli, &elli, &eclli); // { dg-warning "-Wstringop-overflow" } + plli = &ealli + 1; + cmpxchg (plli, &elli, &eclli); // { dg-warning "-Wstringop-overflow" } +} diff --git a/gcc/testsuite/gcc.dg/Wstringop-overflow-78.c b/gcc/testsuite/gcc.dg/Wstringop-overflow-78.c new file mode 100644 index 0000000..a25a418 --- /dev/null +++ b/gcc/testsuite/gcc.dg/Wstringop-overflow-78.c @@ -0,0 +1,518 @@ +/* PR middle-end/102453 - buffer overflow by atomic built-ins not diagnosed + Verify that out-of-bounds accesses by atomic functions are diagnosed with + optimization enabled. + { dg-do compile } + { dg-options "-O3 -Wall -ftrack-macro-expansion=0" } */ + +#ifndef __cplusplus +# define bool _Bool +#endif + +#define NOIPA __attribute__ ((noipa)) + +#define add_fetch(p, q) __atomic_add_fetch (p, q, 0) +#define sub_fetch(p, q) __atomic_sub_fetch (p, q, 0) +#define and_fetch(p, q) __atomic_and_fetch (p, q, 0) +#define or_fetch(p, q) __atomic_or_fetch (p, q, 0) +#define xor_fetch(p, q) __atomic_xor_fetch (p, q, 0) +#define nand_fetch(p, q) __atomic_nand_fetch (p, q, 0) +#define exchange(p, q, r) __atomic_exchange (p, q, r, 0) +#define exchange_n(p, n) __atomic_exchange_n (p, n, 0) +#define cmpxchg(p, q, r) __atomic_compare_exchange (p, q, r, __COUNTER__, 0, 0) + +typedef __SIZE_TYPE__ size_t; + +void sink (void*, ...); +#define sink(...) sink (0, __VA_ARGS__) + +extern _Bool eb; +extern char ec; +extern short int esi; +extern int ei; +extern long int eli; +extern long long int elli; + +extern const _Bool ecb; +extern const char ecc; +extern const short int ecsi; +extern const int eci; +extern const long int ecli; +extern const long long int eclli; + +extern _Atomic _Bool eab; +extern _Atomic char eac; +extern _Atomic short int easi; +extern _Atomic int eai; +extern _Atomic long int eali; +extern _Atomic long long int ealli; + +extern _Atomic const _Bool eacb; +extern _Atomic const char eacc; +extern _Atomic const short int eacsi; +extern _Atomic const int eaci; +extern _Atomic const long int eacli; +extern _Atomic const long long int eaclli; + + +NOIPA void nowarn_atomic_add_fetch (void) +{ + add_fetch (&eac, ecc); + add_fetch (&easi, esi); + add_fetch (&eai, ei); + add_fetch (&eali, eli); + add_fetch (&ealli, elli); +} + + +NOIPA void warn_atomic_add_fetch (void) +{ + _Atomic char *pc = &eac + 1; + add_fetch (pc, ecc); // { dg-warning "-Wstringop-overflow" } + + _Atomic short *psi = (_Atomic short*)((char*)&easi + 1); + add_fetch (psi, esi); // { dg-warning "-Wstringop-overflow" } + psi = (_Atomic short*)((char*)&easi + 2); + add_fetch (psi, esi); // { dg-warning "-Wstringop-overflow" } + + _Atomic int *pi = (_Atomic int*)((char*)&eai + 1); + add_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + 2); + add_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + sizeof eai); + add_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + + _Atomic long *pli = (_Atomic long*)((char*)&eali + 1); + add_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + pli = (_Atomic long*)((char*)&eali + 1); + add_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + pli = &eali + 1; + add_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + + _Atomic long long *plli = (_Atomic long long*)((char*)&ealli + 1); + add_fetch (plli, elli); // { dg-warning "-Wstringop-overflow" } + plli = (_Atomic long long*)((char*)&ealli + 1); + add_fetch (plli, eali); // { dg-warning "-Wstringop-overflow" } + plli = &ealli + 1; + add_fetch (plli, elli); // { dg-warning "-Wstringop-overflow" } +} + + +NOIPA void nowarn_atomic_sub_fetch (void) +{ + _Atomic char *pc = &eac; + sub_fetch (pc, ecc); + + _Atomic short *psi = &easi; + sub_fetch (psi, esi); + + _Atomic int *pi = &eai; + sub_fetch (pi, ei); + + _Atomic long *pli = &eali; + sub_fetch (pli, eli); + + _Atomic long long *plli = &ealli; + sub_fetch (plli, elli); +} + + +NOIPA void warn_atomic_sub_fetch (void) +{ + _Atomic char *pc = &eac + 1; + sub_fetch (pc, ecc); // { dg-warning "-Wstringop-overflow" } + + _Atomic short *psi = (_Atomic short*)((char*)&easi + 1); + sub_fetch (psi, esi); // { dg-warning "-Wstringop-overflow" } + psi = (_Atomic short*)((char*)&easi + 2); + sub_fetch (psi, esi); // { dg-warning "-Wstringop-overflow" } + + _Atomic int *pi = (_Atomic int*)((char*)&eai + 1); + sub_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + 2); + sub_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + sizeof eai); + sub_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + + _Atomic long *pli = (_Atomic long*)((char*)&eali + 1); + sub_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + pli = (_Atomic long*)((char*)&eali + 1); + sub_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + pli = &eali + 1; + sub_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + + _Atomic long long *plli = (_Atomic long long*)((char*)&ealli + 1); + sub_fetch (plli, elli); // { dg-warning "-Wstringop-overflow" } + plli = (_Atomic long long*)((char*)&ealli + 1); + sub_fetch (plli, eali); // { dg-warning "-Wstringop-overflow" } + plli = &ealli + 1; + sub_fetch (plli, elli); // { dg-warning "-Wstringop-overflow" } +} + + +NOIPA void nowarn_atomic_and_fetch (void) +{ + _Atomic char *pc = &eac; + and_fetch (pc, ecc); + + _Atomic short *psi = &easi; + and_fetch (psi, esi); + + _Atomic int *pi = &eai; + and_fetch (pi, ei); + + _Atomic long *pli = &eali; + and_fetch (pli, eli); + + _Atomic long long *plli = &ealli; + and_fetch (plli, elli); +} + + +NOIPA void warn_atomic_and_fetch (void) +{ + _Atomic char *pc = &eac + 1; + and_fetch (pc, ecc); // { dg-warning "-Wstringop-overflow" } + + _Atomic short *psi = (_Atomic short*)((char*)&easi + 1); + and_fetch (psi, esi); // { dg-warning "-Wstringop-overflow" } + psi = (_Atomic short*)((char*)&easi + 2); + and_fetch (psi, esi); // { dg-warning "-Wstringop-overflow" } + + _Atomic int *pi = (_Atomic int*)((char*)&eai + 1); + and_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + 2); + and_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + sizeof eai); + and_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + + _Atomic long *pli = (_Atomic long*)((char*)&eali + 1); + and_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + pli = (_Atomic long*)((char*)&eali + 1); + and_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + pli = &eali + 1; + and_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + + _Atomic long long *plli = (_Atomic long long*)((char*)&ealli + 1); + and_fetch (plli, elli); // { dg-warning "-Wstringop-overflow" } + plli = (_Atomic long long*)((char*)&ealli + 1); + and_fetch (plli, eali); // { dg-warning "-Wstringop-overflow" } + plli = &ealli + 1; + and_fetch (plli, elli); // { dg-warning "-Wstringop-overflow" } +} + + +NOIPA void nowarn_atomic_or_fetch (void) +{ + _Atomic char *pc = &eac; + or_fetch (pc, ecc); + + _Atomic short *psi = &easi; + or_fetch (psi, esi); + + _Atomic int *pi = &eai; + or_fetch (pi, ei); + + _Atomic long *pli = &eali; + or_fetch (pli, eli); + + _Atomic long long *plli = &ealli; + or_fetch (plli, elli); +} + + +NOIPA void warn_atomic_or_fetch (void) +{ + _Atomic char *pc = &eac + 1; + or_fetch (pc, ecc); // { dg-warning "-Wstringop-overflow" } + + _Atomic short *psi = (_Atomic short*)((char*)&easi + 1); + or_fetch (psi, esi); // { dg-warning "-Wstringop-overflow" } + psi = (_Atomic short*)((char*)&easi + 2); + or_fetch (psi, esi); // { dg-warning "-Wstringop-overflow" } + + _Atomic int *pi = (_Atomic int*)((char*)&eai + 1); + or_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + 2); + or_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + sizeof eai); + or_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + + _Atomic long *pli = (_Atomic long*)((char*)&eali + 1); + or_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + pli = (_Atomic long*)((char*)&eali + 1); + or_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + pli = &eali + 1; + or_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + + _Atomic long long *plli = (_Atomic long long*)((char*)&ealli + 1); + or_fetch (plli, elli); // { dg-warning "-Wstringop-overflow" } + plli = (_Atomic long long*)((char*)&ealli + 1); + or_fetch (plli, eali); // { dg-warning "-Wstringop-overflow" } + plli = &ealli + 1; + or_fetch (plli, elli); // { dg-warning "-Wstringop-overflow" } +} + + +NOIPA void nowarn_atomic_xor_fetch (void) +{ + _Atomic char *pc = &eac; + xor_fetch (pc, ecc); + + _Atomic short *psi = &easi; + xor_fetch (psi, esi); + + _Atomic int *pi = &eai; + xor_fetch (pi, ei); + + _Atomic long *pli = &eali; + xor_fetch (pli, eli); + + _Atomic long long *plli = &ealli; + xor_fetch (plli, elli); +} + + +NOIPA void warn_atomic_xor_fetch (void) +{ + _Atomic char *pc = &eac + 1; + xor_fetch (pc, ecc); // { dg-warning "-Wstringop-overflow" } + + _Atomic short *psi = (_Atomic short*)((char*)&easi + 1); + xor_fetch (psi, esi); // { dg-warning "-Wstringop-overflow" } + psi = (_Atomic short*)((char*)&easi + 1); + xor_fetch (psi, esi); // { dg-warning "-Wstringop-overflow" } + + _Atomic int *pi = (_Atomic int*)((char*)&eai + 1); + xor_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + 2); + xor_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + sizeof eai); + xor_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + + _Atomic long *pli = (_Atomic long*)((char*)&eali + 1); + xor_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + pli = (_Atomic long*)((char*)&eali + 1); + xor_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + pli = &eali + 1; + xor_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + + _Atomic long long *plli = (_Atomic long long*)((char*)&ealli + 1); + xor_fetch (plli, elli); // { dg-warning "-Wstringop-overflow" } + plli = (_Atomic long long*)((char*)&eali + 1); + xor_fetch (plli, eali); // { dg-warning "-Wstringop-overflow" } + plli = &ealli + 1; + xor_fetch (plli, elli); // { dg-warning "-Wstringop-overflow" } +} + + +NOIPA void nowarn_atomic_nand_fetch (void) +{ + _Atomic char *pc = &eac; + nand_fetch (pc, ecc); + + _Atomic short *psi = &easi; + nand_fetch (psi, esi); + + _Atomic int *pi = &eai; + nand_fetch (pi, ei); + + _Atomic long *pli = &eali; + nand_fetch (pli, eli); + + _Atomic long long *plli = &ealli; + nand_fetch (plli, elli); +} + + +NOIPA void warn_atomic_nand_fetch (void) +{ + _Atomic char *pc = &eac + 1; + nand_fetch (pc, ecc); // { dg-warning "-Wstringop-overflow" } + + _Atomic short *psi = (_Atomic short*)((char*)&easi + 1); + nand_fetch (psi, esi); // { dg-warning "-Wstringop-overflow" } + psi = (_Atomic short*)((char*)&easi + 1); + nand_fetch (psi, esi); // { dg-warning "-Wstringop-overflow" } + + _Atomic int *pi = (_Atomic int*)((char*)&eai + 1); + nand_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + 2); + nand_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + sizeof eai); + nand_fetch (pi, ei); // { dg-warning "-Wstringop-overflow" } + + _Atomic long *pli = (_Atomic long*)((char*)&eali + 1); + nand_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + pli = (_Atomic long*)((char*)&eali + 1); + nand_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + pli = &eali + 1; + nand_fetch (pli, eli); // { dg-warning "-Wstringop-overflow" } + + _Atomic long long *plli = (_Atomic long long*)((char*)&ealli + 1); + nand_fetch (plli, elli); // { dg-warning "-Wstringop-overflow" } + plli = (_Atomic long long*)((char*)&eai + 1); + nand_fetch (plli, eali); // { dg-warning "-Wstringop-overflow" } + plli = &ealli + 1; + nand_fetch (plli, elli); // { dg-warning "-Wstringop-overflow" } +} + + +NOIPA void nowarn_atomic_exchange (void) +{ + char rc; + _Atomic char *pc = &eac; + exchange (pc, &ecc, &rc); + + short rsi; + _Atomic short *psi = &easi; + exchange (psi, &esi, &rsi); + + int ri; + _Atomic int *pi = &eai; + exchange (pi, &ei, &ri); + + long rli; + _Atomic long *pli = &eali; + exchange (pli, &eli, &rli); + + long long rlli; + _Atomic long long *plli = &ealli; + exchange (plli, &elli, &rlli); + + sink (&rc, &rsi, &ri, &rli, &rlli); +} + +NOIPA void warn_atomic_exchange (void) +{ + char rc; + _Atomic char *pc = &eac + 1; + exchange (pc, &ecc, &rc); // { dg-warning "-Wstringop-overflow" } + + short rsi[2]; + _Atomic short *psi = (_Atomic short*)((char*)&easi + 1); + exchange (psi, &ecsi, rsi); // { dg-warning "-Wstringop-overflow" } + psi = (_Atomic short*)((char*)&easi + 2); + exchange (psi, &ecsi, rsi + 1); // { dg-warning "-Wstringop-overflow" } + + int ri[3]; + _Atomic int *pi = (_Atomic int*)((char*)&eai + 1); + exchange (pi, &eci, ri); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + 2); + exchange (pi, &eci, ri + 1); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + sizeof eai); + exchange (pi, &eci, ri + 2); // { dg-warning "-Wstringop-overflow" } + + long rli[3]; + _Atomic long *pli = (_Atomic long*)((char*)&eali + 1); + exchange (pli, &ecli, rli); // { dg-warning "-Wstringop-overflow" } + pli = (_Atomic long*)((char*)&eali + 1); + exchange (pli, &ecli, rli + 1); // { dg-warning "-Wstringop-overflow" } + pli = &eali + 1; + exchange (pli, &ecli, rli + 2); // { dg-warning "-Wstringop-overflow" } + + long long rlli[3]; + _Atomic long long *plli = (_Atomic long long*)((char*)&ealli + 1); + exchange (plli, &eclli, rlli); // { dg-warning "-Wstringop-overflow" } + plli = (_Atomic long long*)((char*)&ealli + 1); + exchange (plli, &eclli, rlli + 1); // { dg-warning "-Wstringop-overflow" } + plli = &ealli + 1; + exchange (plli, &eclli, rlli + 2); // { dg-warning "-Wstringop-overflow" } + + sink (&rc, rsi, ri, rli, rlli); +} + + +NOIPA void nowarn_atomic_exchange_n (_Atomic unsigned char *pauc, + _Atomic unsigned short *pausi, + _Atomic unsigned int *paui, + _Atomic unsigned long *pauli, + _Atomic unsigned long long *paulli) +{ + char rc = exchange_n (&eac, ecc); + short rsi = exchange_n (&easi, esi); + int ri = exchange_n (&eai, ei); + long rli = exchange_n (&eali, eli); + long long rlli = exchange_n (&ealli, elli); + + sink (rc, rsi, ri, rli, rlli); + + char ruc = exchange_n (pauc, ecc); + short rusi = exchange_n (pausi, esi); + int rui = exchange_n (paui, ei); + long ruli = exchange_n (pauli, eli); + long long rulli = exchange_n (paulli, elli); + + sink (ruc, rusi, rui, ruli, rulli); +} + + +NOIPA void warn_atomic_exchange_n (void) +{ + _Atomic char *pc = &eac + 1; + char rc = exchange_n (pc, ecc); // { dg-warning "-Wstringop-overflow" } + + short rsi[2]; + _Atomic short *psi = (_Atomic short*)((char*)&easi + 1); + rsi[0] = exchange_n (psi, ecsi); // { dg-warning "-Wstringop-overflow" } + psi = (_Atomic short*)((char*)&easi + 2); + rsi[1] = exchange_n (psi, ecsi); // { dg-warning "-Wstringop-overflow" } + + int ri[3]; + _Atomic int *pi = (_Atomic int*)((char*)&eai + 1); + ri[0] = exchange_n (pi, eci); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + 2); + ri[1] = exchange_n (pi, eci); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + sizeof eai); + ri[2] = exchange_n (pi, eci); // { dg-warning "-Wstringop-overflow" } + + long rli[3]; + _Atomic long *pli = (_Atomic long*)((char*)&eali + 1); + rli[0] = exchange_n (pli, ecli); // { dg-warning "-Wstringop-overflow" } + pli = (_Atomic long*)((char*)&eali + 1); + rli[1] = exchange_n (pli, ecli); // { dg-warning "-Wstringop-overflow" } + pli = &eali + 1; + rli[2] = exchange_n (pli, ecli); // { dg-warning "-Wstringop-overflow" } + + long long rlli[3]; + _Atomic long long *plli = (_Atomic long long*)((char*)&ealli + 1); + rlli[0] = exchange_n (plli, eclli); // { dg-warning "-Wstringop-overflow" } + plli = (_Atomic long long*)((char*)&ealli + 1); + rlli[1] = exchange_n (plli, eclli); // { dg-warning "-Wstringop-overflow" } + plli = &ealli + 1; + rlli[2] = exchange_n (plli, eclli); // { dg-warning "-Wstringop-overflow" } + + sink (&rc, rsi, ri, rli, rlli); +} + + +NOIPA void warn_atomic_compare_exchange (void) +{ + _Atomic char *pc = &eac + 1; + cmpxchg (pc, &ec, &ecc); // { dg-warning "-Wstringop-overflow" } + + _Atomic short *psi = (_Atomic short*)((char*)&easi + 1); + cmpxchg (psi, &esi, &ecsi); // { dg-warning "-Wstringop-overflow" } + psi = (_Atomic short*)((char*)&easi + 2); + cmpxchg (psi, &esi, &ecsi); // { dg-warning "-Wstringop-overflow" } + + _Atomic int *pi = (_Atomic int*)((char*)&eai + 1); + cmpxchg (pi, &ei, &eci); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + 2); + cmpxchg (pi, &ei, &eci); // { dg-warning "-Wstringop-overflow" } + pi = (_Atomic int*)((char*)&eai + sizeof eai); + cmpxchg (pi, &ei, &eci); // { dg-warning "-Wstringop-overflow" } + + _Atomic long *pli = (_Atomic long*)((char*)&eali + 1); + cmpxchg (pli, &eli, &ecli); // { dg-warning "-Wstringop-overflow" } + pli = (_Atomic long*)((char*)&eali + 1); + cmpxchg (pli, &eli, &ecli); // { dg-warning "-Wstringop-overflow" } + pli = &eali + 1; + cmpxchg (pli, &eli, &ecli); // { dg-warning "-Wstringop-overflow" } + + _Atomic long long *plli = (_Atomic long long*)((char*)&ealli + 1); + cmpxchg (plli, &elli, &eclli); // { dg-warning "-Wstringop-overflow" } + plli = (_Atomic long long*)((char*)&ealli + 1); + cmpxchg (plli, &elli, &eclli); // { dg-warning "-Wstringop-overflow" } + plli = &ealli + 1; + cmpxchg (plli, &elli, &eclli); // { dg-warning "-Wstringop-overflow" } +} diff --git a/gcc/testsuite/gcc.dg/Wstringop-overflow-79.c b/gcc/testsuite/gcc.dg/Wstringop-overflow-79.c new file mode 100644 index 0000000..15eb26f --- /dev/null +++ b/gcc/testsuite/gcc.dg/Wstringop-overflow-79.c @@ -0,0 +1,70 @@ +/* Verify that a separate note is issued for each offset into the same + object after a -Wstringop-overflow. Since all arguments are known + the test doesn't need optimization. Wstringop-overflow-79.c verifies + they're also issued at -O2. + { dg-do compile } + { dg-options "-O0 -Wno-array-bounds" } */ + +extern char a[8]; // dg-message at offset \\\[3, 6] into destination object 'a'" "note 1" } + // dg-message at offset \\\[5, 8] into destination object 'a'" "note 2" { target *-*-* } .-1 } + +void test_2_notes (int i) +{ + char *p = i ? a + 3 : a + 5; + __builtin_memset (p, 0, 7); // { dg-warning "-Wstringop-overflow" } +} + + +extern char b[8]; // dg-message at offset \\\[3, 6] into destination object 'b'" "note 1" } + // dg-message at offset \\\[4, 7] into destination object 'b'" "note 2" { target *-*-* } .-1 } + // dg-message at offset \\\[5, 8] into destination object 'b'" "note 3" { target *-*-* } .-2 } + +void test_3_notes (int i) +{ + char *p = i < 0 ? b + 3 : 0 < i ? b + 5 : b + 4; + __builtin_memset (p, 0, 7); // { dg-warning "-Wstringop-overflow" } +} + + +extern char c[8]; // dg-message at offset \\\[3, 6] into destination object 'c'" "note 1" } + // dg-message at offset \\\[4, 7] into destination object 'c'" "note 2" { target *-*-* } .-1 } + // dg-message at offset \\\[5, 8] into destination object 'c'" "note 3" { target *-*-* } .-2 } + // dg-message at offset \\\[6, 8] into destination object 'c'" "note 3" { target *-*-* } .-2 } + +void test_4_notes (int i) +{ + char *p; + if (i < -1) + p = c + 3; + else if (i < 0) + p = c + 4; + else if (0 < i) + p = c + 6; + else + p = c + 5; + + __builtin_memset (p, 0, 7); // { dg-warning "-Wstringop-overflow" } +} + + +extern char d[8]; // dg-message at offset \\\[3, 6] into destination object 'd'" "note 1" } + // dg-message at offset \\\[4, 7] into destination object 'd'" "note 2" { target *-*-* } .-1 } + // dg-message at offset \\\[5, 8] into destination object 'd'" "note 3" { target *-*-* } .-2 } + // dg-message at offset \\\[6, 8] into destination object 'd'" "note 3" { target *-*-* } .-3 } + // dg-message at offset \\\[7, 8] into destination object 'd'" "note 3" { target *-*-* } .-4 } + +void test_5_notes (int i) +{ + char *p; + switch (i) + { + case -9: p = d + 3; break; + case -5: p = d + 4; break; + case 0: p = d + 5; break; + case 3: p = d + 6; break; + case 4: p = d + 7; break; + default: return; + } + + __builtin_memset (p, 0, 7); // { dg-warning "-Wstringop-overflow" } +} diff --git a/gcc/testsuite/gcc.dg/Wstringop-overflow-80.c b/gcc/testsuite/gcc.dg/Wstringop-overflow-80.c new file mode 100644 index 0000000..1628c2f --- /dev/null +++ b/gcc/testsuite/gcc.dg/Wstringop-overflow-80.c @@ -0,0 +1,70 @@ +/* Verify that a separate note is issued for each offset into the same + object after a -Wstringop-overflow. Even though the warnings don't + need optimization the test enables it to verify they're still issued + with it. Wstringop-overflow-78.c verifies they're issued at -O0. + { dg-do compile } + { dg-options "-O2 -Wno-array-bounds" } */ + +extern char a[8]; // dg-message at offset \\\[3, 6] into destination object 'a'" "note 1" } + // dg-message at offset \\\[5, 8] into destination object 'a'" "note 2" { target *-*-* } .-1 } + +void test_2_notes (int i) +{ + char *p = i ? a + 3 : a + 5; + __builtin_memset (p, 0, 7); // { dg-warning "-Wstringop-overflow" } +} + + +extern char b[8]; // dg-message at offset \\\[3, 6] into destination object 'b'" "note 1" } + // dg-message at offset \\\[4, 7] into destination object 'b'" "note 2" { target *-*-* } .-1 } + // dg-message at offset \\\[5, 8] into destination object 'b'" "note 3" { target *-*-* } .-2 } + +void test_3_notes (int i) +{ + char *p = i < 0 ? b + 3 : 0 < i ? b + 5 : b + 4; + __builtin_memset (p, 0, 7); // { dg-warning "-Wstringop-overflow" } +} + + +extern char c[8]; // dg-message at offset \\\[3, 6] into destination object 'c'" "note 1" } + // dg-message at offset \\\[4, 7] into destination object 'c'" "note 2" { target *-*-* } .-1 } + // dg-message at offset \\\[5, 8] into destination object 'c'" "note 3" { target *-*-* } .-2 } + // dg-message at offset \\\[6, 8] into destination object 'c'" "note 3" { target *-*-* } .-2 } + +void test_4_notes (int i) +{ + char *p; + if (i < -1) + p = c + 3; + else if (i < 0) + p = c + 4; + else if (0 < i) + p = c + 6; + else + p = c + 5; + + __builtin_memset (p, 0, 7); // { dg-warning "-Wstringop-overflow" } +} + + +extern char d[8]; // dg-message at offset \\\[3, 6] into destination object 'd'" "note 1" } + // dg-message at offset \\\[4, 7] into destination object 'd'" "note 2" { target *-*-* } .-1 } + // dg-message at offset \\\[5, 8] into destination object 'd'" "note 3" { target *-*-* } .-2 } + // dg-message at offset \\\[6, 8] into destination object 'd'" "note 3" { target *-*-* } .-3 } + // dg-message at offset \\\[7, 8] into destination object 'd'" "note 3" { target *-*-* } .-4 } + +void test_5_notes (int i) +{ + char *p; + switch (i) + { + case -9: p = d + 3; break; + case -5: p = d + 4; break; + case 0: p = d + 5; break; + case 3: p = d + 6; break; + case 4: p = d + 7; break; + default: return; + } + + __builtin_memset (p, 0, 7); // { dg-warning "-Wstringop-overflow" } +} diff --git a/gcc/testsuite/gcc.dg/Wstringop-overflow-81.c b/gcc/testsuite/gcc.dg/Wstringop-overflow-81.c new file mode 100644 index 0000000..e8bc327 --- /dev/null +++ b/gcc/testsuite/gcc.dg/Wstringop-overflow-81.c @@ -0,0 +1,38 @@ +/* Verify that -Wstringop-overflow uses context-sensitive range info + even at -O0. + { dg-do compile } + { dg-options "-O0 -Wall" } */ + +extern void* memset (void*, int, __SIZE_TYPE__); + +char a[8]; + +void warn_offset_range (int i) +{ + if (i < 4) + i = 4; + memset (a + i, 0, 5); // { dg-warning "writing 5 bytes into a region of size 4 " } +} + +void warn_size_range (int i, int n) +{ + if (n < 5) + n = 5; + + memset (a + 4, 1, n); // { dg-warning "writing between 5 and \\d+ bytes into a region of size 4 " } +} + +void warn_offset_and_size_range (int i, int n) +{ + if (n < 5) + n = 5; + + if (i < 4) + { + if (n < 9) + n = 9; + memset (a + i, 1, n); // { dg-warning "writing between 9 and \\d+ bytes into a region of size 8 " } + } + else + memset (a + i, 0, n); // { dg-warning "writing between 5 and \\d+ bytes into a region of size 4 " } +} diff --git a/gcc/testsuite/gcc.dg/Wzero-length-array-bounds-2-novec.c b/gcc/testsuite/gcc.dg/Wzero-length-array-bounds-2-novec.c new file mode 100644 index 0000000..8e023b7 --- /dev/null +++ b/gcc/testsuite/gcc.dg/Wzero-length-array-bounds-2-novec.c @@ -0,0 +1,45 @@ +/* Test to verify that -Wzero-length-bounds and not -Warray-bounds is + issued for accesses to interior zero-length array members that are + within the bounds of the enclosing struct. + { dg-do compile } + { dg-options "-O2 -Wall -fno-tree-vectorize" } */ + +void sink (void*); + +struct A { int i; }; +struct B { int j; struct A a[0]; }; + +struct C +{ + struct B b1; + struct B b2; +}; + +char cbuf1[1 * sizeof (struct C)]; +char cbuf2[2 * sizeof (struct C)] = { }; + +void test_C_global_buf (void) +{ + struct C *p = (struct C*)&cbuf1; + + p->b1.a[-1].i = 0; // { dg-warning "\\\[-Warray-bounds" } + p->b1.a[ 0].i = 0; // { dg-warning "\\\[-Wzero-length-bounds" } + p->b1.a[ 1].i = 0; // { dg-warning "\\\[-Warray-bounds" } + sink (p); + + p->b2.a[ 0].i = 0; // { dg-warning "\\\[-Warray-bounds" } + p->b2.a[ 1].i = 0; // { dg-warning "\\\[-Warray-bounds" } + sink (p); + + p = (struct C*)&cbuf2; + p->b1.a[-1].i = 0; // { dg-warning "\\\[-Warray-bounds" } + p->b1.a[ 0].i = 0; // { dg-warning "\\\[-Wzero-length-bounds" } + p->b1.a[ 1].i = 0; // { dg-warning "\\\[-Wzero-length-bounds" } + sink (p); + + p->b2.a[ 0].i = 0; + p->b2.a[ 1].i = 0; + p->b2.a[ 2].i = 0; // { dg-warning "\\\[-Warray-bounds" } + p->b2.a[ 3].i = 0; // { dg-warning "\\\[-Warray-bounds" } + sink (p); +} diff --git a/gcc/testsuite/gcc.dg/Wzero-length-array-bounds-2.c b/gcc/testsuite/gcc.dg/Wzero-length-array-bounds-2.c index 841b2bf..b232149 100644 --- a/gcc/testsuite/gcc.dg/Wzero-length-array-bounds-2.c +++ b/gcc/testsuite/gcc.dg/Wzero-length-array-bounds-2.c @@ -87,7 +87,7 @@ void test_C_global_buf (void) p->b1.a[ 1].i = 0; // { dg-warning "\\\[-Wzero-length-bounds" } sink (p); - p->b2.a[ 0].i = 0; + p->b2.a[ 0].i = 0; // { dg-warning "\\\[-Wstringop-overflow" "pr102706" { target { vect_slp_v2si_store && { ! vect_slp_v4si_store } } } } p->b2.a[ 1].i = 0; p->b2.a[ 2].i = 0; // { dg-warning "\\\[-Warray-bounds" } p->b2.a[ 3].i = 0; // { dg-warning "\\\[-Warray-bounds" } diff --git a/gcc/testsuite/gcc.dg/analyzer/pr94851-2.c b/gcc/testsuite/gcc.dg/analyzer/pr94851-2.c index 0acf488..62176bd 100644 --- a/gcc/testsuite/gcc.dg/analyzer/pr94851-2.c +++ b/gcc/testsuite/gcc.dg/analyzer/pr94851-2.c @@ -45,7 +45,7 @@ int pamark(void) { if (curbp->b_amark == (AMARK *)NULL) curbp->b_amark = p; else - last->m_next = p; /* { dg-warning "dereference of NULL 'last'" "deref" { xfail *-*-* } } */ + last->m_next = p; /* { dg-warning "dereference of NULL 'last'" "deref" } */ } p->m_name = (char)c; /* { dg-bogus "leak of 'p'" "bogus leak" } */ diff --git a/gcc/testsuite/gcc.dg/format/c11-dfp-printf-1.c b/gcc/testsuite/gcc.dg/format/c11-dfp-printf-1.c new file mode 100644 index 0000000..356a23e --- /dev/null +++ b/gcc/testsuite/gcc.dg/format/c11-dfp-printf-1.c @@ -0,0 +1,35 @@ +/* Test for printf formats: rejection of DFP formats in pedantic mode. */ +/* { dg-do compile } */ +/* { dg-require-effective-target dfp } */ +/* { dg-options "-std=gnu11 -pedantic -Wformat" } */ + +#include "format.h" + +void +foo (_Decimal32 d32, _Decimal64 d64, _Decimal128 d128) /* { dg-warning "ISO C" } */ +{ + printf ("%Ha", d32); /* { dg-warning "C" } */ + printf ("%HA", d32); /* { dg-warning "C" } */ + printf ("%He", d32); /* { dg-warning "C" } */ + printf ("%HE", d32); /* { dg-warning "C" } */ + printf ("%Hf", d32); /* { dg-warning "C" } */ + printf ("%HF", d32); /* { dg-warning "C" } */ + printf ("%Hg", d32); /* { dg-warning "C" } */ + printf ("%HG", d32); /* { dg-warning "C" } */ + printf ("%Da", d64); /* { dg-warning "C" } */ + printf ("%DA", d64); /* { dg-warning "C" } */ + printf ("%De", d64); /* { dg-warning "C" } */ + printf ("%DE", d64); /* { dg-warning "C" } */ + printf ("%Df", d64); /* { dg-warning "C" } */ + printf ("%DF", d64); /* { dg-warning "C" } */ + printf ("%Dg", d64); /* { dg-warning "C" } */ + printf ("%DG", d64); /* { dg-warning "C" } */ + printf ("%DDa", d128); /* { dg-warning "C" } */ + printf ("%DDA", d128); /* { dg-warning "C" } */ + printf ("%DDe", d128); /* { dg-warning "C" } */ + printf ("%DDE", d128); /* { dg-warning "C" } */ + printf ("%DDf", d128); /* { dg-warning "C" } */ + printf ("%DDF", d128); /* { dg-warning "C" } */ + printf ("%DDg", d128); /* { dg-warning "C" } */ + printf ("%DDG", d128); /* { dg-warning "C" } */ +} diff --git a/gcc/testsuite/gcc.dg/format/c11-dfp-scanf-1.c b/gcc/testsuite/gcc.dg/format/c11-dfp-scanf-1.c new file mode 100644 index 0000000..35bd631 --- /dev/null +++ b/gcc/testsuite/gcc.dg/format/c11-dfp-scanf-1.c @@ -0,0 +1,35 @@ +/* Test for scanf formats: rejection of DFP formats in pedantic mode. */ +/* { dg-do compile } */ +/* { dg-require-effective-target dfp } */ +/* { dg-options "-std=gnu11 -pedantic -Wformat" } */ + +#include "format.h" + +void +foo (_Decimal32 *d32, _Decimal64 *d64, _Decimal128 *d128) /* { dg-warning "ISO C" } */ +{ + scanf ("%Ha", d32); /* { dg-warning "C" } */ + scanf ("%HA", d32); /* { dg-warning "C" } */ + scanf ("%He", d32); /* { dg-warning "C" } */ + scanf ("%HE", d32); /* { dg-warning "C" } */ + scanf ("%Hf", d32); /* { dg-warning "C" } */ + scanf ("%HF", d32); /* { dg-warning "C" } */ + scanf ("%Hg", d32); /* { dg-warning "C" } */ + scanf ("%HG", d32); /* { dg-warning "C" } */ + scanf ("%Da", d64); /* { dg-warning "C" } */ + scanf ("%DA", d64); /* { dg-warning "C" } */ + scanf ("%De", d64); /* { dg-warning "C" } */ + scanf ("%DE", d64); /* { dg-warning "C" } */ + scanf ("%Df", d64); /* { dg-warning "C" } */ + scanf ("%DF", d64); /* { dg-warning "C" } */ + scanf ("%Dg", d64); /* { dg-warning "C" } */ + scanf ("%DG", d64); /* { dg-warning "C" } */ + scanf ("%DDa", d128); /* { dg-warning "C" } */ + scanf ("%DDA", d128); /* { dg-warning "C" } */ + scanf ("%DDe", d128); /* { dg-warning "C" } */ + scanf ("%DDE", d128); /* { dg-warning "C" } */ + scanf ("%DDf", d128); /* { dg-warning "C" } */ + scanf ("%DDF", d128); /* { dg-warning "C" } */ + scanf ("%DDg", d128); /* { dg-warning "C" } */ + scanf ("%DDG", d128); /* { dg-warning "C" } */ +} diff --git a/gcc/testsuite/gcc.dg/format/c11-printf-1.c b/gcc/testsuite/gcc.dg/format/c11-printf-1.c new file mode 100644 index 0000000..7b8a992 --- /dev/null +++ b/gcc/testsuite/gcc.dg/format/c11-printf-1.c @@ -0,0 +1,13 @@ +/* Test for printf formats: rejection of C2X (and C2X-recommended) formats in + pedantic mode. */ +/* { dg-do compile } */ +/* { dg-options "-std=c11 -pedantic -Wformat" } */ + +#include "format.h" + +void +foo (int i) +{ + printf ("%b", i); /* { dg-warning "C" } */ + printf ("%B", i); /* { dg-warning "C" } */ +} diff --git a/gcc/testsuite/gcc.dg/format/c11-scanf-1.c b/gcc/testsuite/gcc.dg/format/c11-scanf-1.c new file mode 100644 index 0000000..d2b9bfb --- /dev/null +++ b/gcc/testsuite/gcc.dg/format/c11-scanf-1.c @@ -0,0 +1,11 @@ +/* Test for printf formats: rejection of C2X formats in pedantic mode. */ +/* { dg-do compile } */ +/* { dg-options "-std=c11 -pedantic -Wformat" } */ + +#include "format.h" + +void +foo (unsigned int *uip) +{ + scanf ("%b", uip); /* { dg-warning "C" } */ +} diff --git a/gcc/testsuite/gcc.dg/format/c2x-dfp-printf-1.c b/gcc/testsuite/gcc.dg/format/c2x-dfp-printf-1.c new file mode 100644 index 0000000..dc40f99 --- /dev/null +++ b/gcc/testsuite/gcc.dg/format/c2x-dfp-printf-1.c @@ -0,0 +1,35 @@ +/* Test for printf formats: acceptance of DFP formats in pedantic mode. */ +/* { dg-do compile } */ +/* { dg-require-effective-target dfp } */ +/* { dg-options "-std=c2x -pedantic -Wformat" } */ + +#include "format.h" + +void +foo (_Decimal32 d32, _Decimal64 d64, _Decimal128 d128) +{ + printf ("%Ha", d32); + printf ("%HA", d32); + printf ("%He", d32); + printf ("%HE", d32); + printf ("%Hf", d32); + printf ("%HF", d32); + printf ("%Hg", d32); + printf ("%HG", d32); + printf ("%Da", d64); + printf ("%DA", d64); + printf ("%De", d64); + printf ("%DE", d64); + printf ("%Df", d64); + printf ("%DF", d64); + printf ("%Dg", d64); + printf ("%DG", d64); + printf ("%DDa", d128); + printf ("%DDA", d128); + printf ("%DDe", d128); + printf ("%DDE", d128); + printf ("%DDf", d128); + printf ("%DDF", d128); + printf ("%DDg", d128); + printf ("%DDG", d128); +} diff --git a/gcc/testsuite/gcc.dg/format/c2x-dfp-scanf-1.c b/gcc/testsuite/gcc.dg/format/c2x-dfp-scanf-1.c new file mode 100644 index 0000000..81e39a9 --- /dev/null +++ b/gcc/testsuite/gcc.dg/format/c2x-dfp-scanf-1.c @@ -0,0 +1,35 @@ +/* Test for scanf formats: acceptance of DFP formats in pedantic mode. */ +/* { dg-do compile } */ +/* { dg-require-effective-target dfp } */ +/* { dg-options "-std=c2x -pedantic -Wformat" } */ + +#include "format.h" + +void +foo (_Decimal32 *d32, _Decimal64 *d64, _Decimal128 *d128) +{ + scanf ("%Ha", d32); + scanf ("%HA", d32); + scanf ("%He", d32); + scanf ("%HE", d32); + scanf ("%Hf", d32); + scanf ("%HF", d32); + scanf ("%Hg", d32); + scanf ("%HG", d32); + scanf ("%Da", d64); + scanf ("%DA", d64); + scanf ("%De", d64); + scanf ("%DE", d64); + scanf ("%Df", d64); + scanf ("%DF", d64); + scanf ("%Dg", d64); + scanf ("%DG", d64); + scanf ("%DDa", d128); + scanf ("%DDA", d128); + scanf ("%DDe", d128); + scanf ("%DDE", d128); + scanf ("%DDf", d128); + scanf ("%DDF", d128); + scanf ("%DDg", d128); + scanf ("%DDG", d128); +} diff --git a/gcc/testsuite/gcc.dg/format/c2x-printf-1.c b/gcc/testsuite/gcc.dg/format/c2x-printf-1.c new file mode 100644 index 0000000..3ae7713 --- /dev/null +++ b/gcc/testsuite/gcc.dg/format/c2x-printf-1.c @@ -0,0 +1,26 @@ +/* Test for printf formats. Formats using C2X features. */ +/* { dg-do compile } */ +/* { dg-options "-std=c2x -pedantic -Wformat" } */ + +#include "format.h" + +void +foo (unsigned int u, unsigned short us, unsigned char uc, unsigned long ul, + unsigned long long ull, uintmax_t uj, size_t z, unsigned_ptrdiff_t ut) +{ + /* Use of %b with each length modifier and other valid features. */ + printf ("%b %hb %hhb %lb %llb %jb %zb %tb\n", u, us, uc, ul, ull, uj, z, ut); + printf ("%*.*llb\n", 1, 2, ull); + printf ("%-b\n", u); + printf ("%#b\n", u); + printf ("%08b\n", u); + /* Flags valid on signed conversions only. */ + printf ("%+b\n", u); /* { dg-warning "flag" } */ + printf ("% b\n", u); /* { dg-warning "flag" } */ + /* Flags ignored in certain combinations. */ + printf ("%-08b\n", u); /* { dg-warning "ignored" } */ + printf ("%08.5b\n", u); /* { dg-warning "ignored" } */ + /* Use of 'L' and 'q' for long long is an extension. */ + printf ("%Lb", ull); /* { dg-warning "does not support" } */ + printf ("%qb", ull); /* { dg-warning "does not support" } */ +} diff --git a/gcc/testsuite/gcc.dg/format/c2x-scanf-1.c b/gcc/testsuite/gcc.dg/format/c2x-scanf-1.c new file mode 100644 index 0000000..f46a715 --- /dev/null +++ b/gcc/testsuite/gcc.dg/format/c2x-scanf-1.c @@ -0,0 +1,17 @@ +/* Test for scanf formats. Formats using C2X features. */ +/* { dg-do compile } */ +/* { dg-options "-std=c2x -pedantic -Wformat" } */ + +#include "format.h" + +void +foo (unsigned int *uip, unsigned short int *uhp, unsigned char *uhhp, + unsigned long int *ulp, unsigned long long *ullp, uintmax_t *ujp, + size_t *zp, unsigned_ptrdiff_t *utp) +{ + scanf ("%*b"); + scanf ("%2b", uip); + scanf ("%hb%hhb%lb%llb%jb%zb%tb", uhp, uhhp, ulp, ullp, ujp, zp, utp); + scanf ("%Lb", ullp); /* { dg-warning "does not support" } */ + scanf ("%qb", ullp); /* { dg-warning "does not support" } */ +} diff --git a/gcc/testsuite/gcc.dg/format/ext-10.c b/gcc/testsuite/gcc.dg/format/ext-10.c new file mode 100644 index 0000000..370ea86 --- /dev/null +++ b/gcc/testsuite/gcc.dg/format/ext-10.c @@ -0,0 +1,13 @@ +/* Test for scanf format extensions using formats from C2X. */ +/* { dg-do compile } */ +/* { dg-options "-std=gnu2x -Wformat" } */ + +#include "format.h" + +void +foo (u_quad_t *uqp, unsigned long long int *ullp) +{ + /* Deprecated length modifiers with %b. */ + scanf ("%qb", uqp); + scanf ("%Lb", ullp); +} diff --git a/gcc/testsuite/gcc.dg/format/ext-9.c b/gcc/testsuite/gcc.dg/format/ext-9.c new file mode 100644 index 0000000..15f59e2 --- /dev/null +++ b/gcc/testsuite/gcc.dg/format/ext-9.c @@ -0,0 +1,29 @@ +/* Test for printf format extensions using formats from or recommended by + C2X. */ +/* { dg-do compile } */ +/* { dg-options "-std=gnu2x -Wformat" } */ + +#include "format.h" + +void +foo (u_quad_t uq, unsigned int u, unsigned short us, unsigned char uc, + unsigned long ul, unsigned long long ull, uintmax_t uj, size_t z, + unsigned_ptrdiff_t ut) +{ + /* Deprecated length modifiers with %b and %B. */ + printf ("%qb%qB", uq, uq); + printf ("%Lb%LB", ull, ull); + printf ("%Zb%ZB", z, z); + /* Use of %B in cases valid for %b. */ + printf ("%B %hB %hhB %lB %llB %jB %zB %tB\n", u, us, uc, ul, ull, uj, z, ut); + printf ("%*.*llB\n", 1, 2, ull); + printf ("%-B\n", u); + printf ("%#B\n", u); + printf ("%08B\n", u); + /* Flags valid on signed conversions only. */ + printf ("%+B\n", u); /* { dg-warning "flag" } */ + printf ("% B\n", u); /* { dg-warning "flag" } */ + /* Flags ignored in certain combinations. */ + printf ("%-08B\n", u); /* { dg-warning "ignored" } */ + printf ("%08.5B\n", u); /* { dg-warning "ignored" } */ +} diff --git a/gcc/testsuite/gcc.dg/gimplefe-error-12.c b/gcc/testsuite/gcc.dg/gimplefe-error-12.c new file mode 100644 index 0000000..981ff7b --- /dev/null +++ b/gcc/testsuite/gcc.dg/gimplefe-error-12.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-fgimple" } */ + +int get_current (); + +__GIMPLE +void foo() +{ + get_current()->flags; /* { dg-error "non-pointer" } */ +} diff --git a/gcc/testsuite/gcc.dg/gomp/sections-2.c b/gcc/testsuite/gcc.dg/gomp/sections-2.c index aabdfaf..6d8305a 100644 --- a/gcc/testsuite/gcc.dg/gomp/sections-2.c +++ b/gcc/testsuite/gcc.dg/gomp/sections-2.c @@ -19,11 +19,11 @@ void foo(void) { #pragma omp section bar(2); - bar(3); // { dg-error "expected" } + bar(3); bar(4); #pragma omp section bar(5); - bar(6); // { dg-error "expected" } + bar(6); bar(7); } } diff --git a/gcc/testsuite/gcc.dg/gomp/simd-2.c b/gcc/testsuite/gcc.dg/gomp/simd-2.c index f491212..85acb98 100644 --- a/gcc/testsuite/gcc.dg/gomp/simd-2.c +++ b/gcc/testsuite/gcc.dg/gomp/simd-2.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-O2 -fopenmp -fvect-cost-model=cheap -fdump-tree-vect-details" } */ +/* { dg-options "-O2 -fopenmp -fdump-tree-vect-details" } */ /* { dg-additional-options "-msse2" { target { i?86-*-* x86_64-*-* } } } */ /* { dg-additional-options "-mavx" { target avx } } */ /* { dg-final { scan-tree-dump-times "vectorized \[1-9]\[0-9]* loops in function" 5 "vect" { target i?86-*-* x86_64-*-* aarch64-*-* } } } */ diff --git a/gcc/testsuite/gcc.dg/gomp/simd-3.c b/gcc/testsuite/gcc.dg/gomp/simd-3.c index c75060c..86fee85 100644 --- a/gcc/testsuite/gcc.dg/gomp/simd-3.c +++ b/gcc/testsuite/gcc.dg/gomp/simd-3.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-O2 -fopenmp -fvect-cost-model=cheap -fdump-tree-vect-details" } */ +/* { dg-options "-O2 -fopenmp -fdump-tree-vect-details" } */ /* { dg-additional-options "-msse2" { target { i?86-*-* x86_64-*-* } } } */ /* { dg-additional-options "-mavx" { target avx } } */ /* { dg-final { scan-tree-dump-times "vectorized \[1-9]\[0-9]* loops in function" 5 "vect" { target i?86-*-* x86_64-*-* aarch64-*-* } } } */ diff --git a/gcc/testsuite/gcc.dg/graphite/pr69728.c b/gcc/testsuite/gcc.dg/graphite/pr69728.c index 69e2831..a6f3857 100644 --- a/gcc/testsuite/gcc.dg/graphite/pr69728.c +++ b/gcc/testsuite/gcc.dg/graphite/pr69728.c @@ -24,6 +24,4 @@ fn1 () run into scheduling issues before here, not being able to handle empty domains. */ -/* XFAILed by fix for PR86865. */ - -/* { dg-final { scan-tree-dump "loop nest optimized" "graphite" { xfail *-*-* } } } */ +/* { dg-final { scan-tree-dump "loop nest optimized" "graphite" } } */ diff --git a/gcc/testsuite/gcc.dg/graphite/scop-dsyr2k-2.c b/gcc/testsuite/gcc.dg/graphite/scop-dsyr2k-2.c index 06aa19a..42e23fc 100644 --- a/gcc/testsuite/gcc.dg/graphite/scop-dsyr2k-2.c +++ b/gcc/testsuite/gcc.dg/graphite/scop-dsyr2k-2.c @@ -1,4 +1,5 @@ /* { dg-require-effective-target size32plus } */ +/* { dg-additional-options "-fno-thread-jumps" } */ #define NMAX 3000 static double a[NMAX][NMAX], b[NMAX][NMAX], c[NMAX][NMAX]; diff --git a/gcc/testsuite/gcc.dg/graphite/scop-dsyr2k.c b/gcc/testsuite/gcc.dg/graphite/scop-dsyr2k.c index 925ae30..feb9935 100644 --- a/gcc/testsuite/gcc.dg/graphite/scop-dsyr2k.c +++ b/gcc/testsuite/gcc.dg/graphite/scop-dsyr2k.c @@ -1,4 +1,5 @@ /* { dg-require-effective-target size32plus } */ +/* { dg-additional-options "-fno-thread-jumps" } */ #define NMAX 3000 static double a[NMAX][NMAX], b[NMAX][NMAX], c[NMAX][NMAX]; @@ -17,4 +18,4 @@ void dsyr2k(int N) { #pragma endscop } -/* { dg-final { scan-tree-dump-times "number of SCoPs: 1" 1 "graphite" { xfail *-*-* } } } */ +/* { dg-final { scan-tree-dump-times "number of SCoPs: 1" 1 "graphite" } } */ diff --git a/gcc/testsuite/gcc.dg/graphite/scop-dsyrk-2.c b/gcc/testsuite/gcc.dg/graphite/scop-dsyrk-2.c index 5622dce..935ade3 100644 --- a/gcc/testsuite/gcc.dg/graphite/scop-dsyrk-2.c +++ b/gcc/testsuite/gcc.dg/graphite/scop-dsyrk-2.c @@ -1,4 +1,5 @@ /* { dg-require-effective-target size32plus } */ +/* { dg-additional-options "-fno-thread-jumps" } */ #define NMAX 3000 #define MEASURE_TIME 1 diff --git a/gcc/testsuite/gcc.dg/graphite/scop-dsyrk.c b/gcc/testsuite/gcc.dg/graphite/scop-dsyrk.c index b748946..5c65e40 100644 --- a/gcc/testsuite/gcc.dg/graphite/scop-dsyrk.c +++ b/gcc/testsuite/gcc.dg/graphite/scop-dsyrk.c @@ -1,4 +1,5 @@ /* { dg-require-effective-target size32plus } */ +/* { dg-additional-options "-fno-thread-jumps" } */ #define NMAX 3000 #define MEASURE_TIME 1 @@ -19,4 +20,4 @@ void dsyrk(int N) #pragma endscop } -/* { dg-final { scan-tree-dump-times "number of SCoPs: 1" 1 "graphite" { xfail *-*-* } } } */ +/* { dg-final { scan-tree-dump-times "number of SCoPs: 1" 1 "graphite" } } */ diff --git a/gcc/testsuite/gcc.dg/ipa/pr102714.c b/gcc/testsuite/gcc.dg/ipa/pr102714.c new file mode 100644 index 0000000..65dd86f --- /dev/null +++ b/gcc/testsuite/gcc.dg/ipa/pr102714.c @@ -0,0 +1,117 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -fno-strict-aliasing -fdump-ipa-sra-details -fdump-tree-optimized" } */ + +typedef _Bool bool; + +enum { + false = 0, + true = 1 +}; + +struct xarray { + unsigned int xa_lock; + unsigned int xa_flags; + void * xa_head; + +}; + +struct list_head { + struct list_head *next, *prev; +}; + +struct callback_head { + struct callback_head *next; + void (*func)(struct callback_head *head); +} __attribute__((aligned(sizeof(void *)))); + +struct xa_node { + unsigned char shift; + unsigned char offset; + unsigned char count; + unsigned char nr_values; + struct xa_node *parent; + struct xarray *array; + union { + struct list_head private_list; + struct callback_head callback_head; + }; + void *slots[(1UL << (0 ? 4 : 6))]; + union { + unsigned long tags[3][((((1UL << (0 ? 4 : 6))) + (64) - 1) / (64))]; + unsigned long marks[3][((((1UL << (0 ? 4 : 6))) + (64) - 1) / (64))]; + }; +}; + +static inline __attribute__((__gnu_inline__)) __attribute__((__unused__)) __attribute__((no_instrument_function)) unsigned long shift_maxindex(unsigned int shift) +{ + return ((1UL << (0 ? 4 : 6)) << shift) - 1; +} + +static inline __attribute__((__gnu_inline__)) __attribute__((__unused__)) __attribute__((no_instrument_function)) unsigned long node_maxindex(const struct xa_node *node) +{ + return shift_maxindex(node->shift); +} + +static inline __attribute__((__gnu_inline__)) __attribute__((__unused__)) __attribute__((no_instrument_function)) struct xa_node *entry_to_node(void *ptr) +{ + return (void *)((unsigned long)ptr & ~2UL); +} + +static inline __attribute__((__gnu_inline__)) __attribute__((__unused__)) __attribute__((no_instrument_function)) bool radix_tree_is_internal_node(void *ptr) +{ + return ((unsigned long)ptr & 3UL) == + 2UL; +} + +static inline __attribute__((__gnu_inline__)) __attribute__((__unused__)) __attribute__((no_instrument_function)) void *xa_mk_internal(unsigned long v) +{ + return (void *)((v << 2) | 2); +} + +static unsigned radix_tree_load_root(const struct xarray *root, + struct xa_node **nodep, unsigned long *maxindex) +{ + struct xa_node *node = + ({ + typeof(root->xa_head) ________p1 = ({(*(const volatile typeof(root->xa_head) *)&(root->xa_head)); }); + ((typeof(*root->xa_head) *)(________p1)); + }); + + *nodep = node; + + if (__builtin_expect(!!(radix_tree_is_internal_node(node)), 1)) { + node = entry_to_node(node); + *maxindex = node_maxindex(node); + return node->shift + (0 ? 4 : 6); + } + + *maxindex = 0; + return 0; +} + +void *__radix_tree_lookup(const struct xarray *root, + unsigned long index, struct xa_node **nodep, + void ***slotp) +{ + struct xa_node *node, *parent; + unsigned long maxindex; + + restart: + parent = ((void *)0); + radix_tree_load_root(root, &node, &maxindex); + while (radix_tree_is_internal_node(node)) { + + parent = entry_to_node(node); + if (node == xa_mk_internal(256)) + goto restart; + if (parent->shift == 0) + break; + } + if (nodep) + *nodep = parent; + + return node; +} + +/* { dg-final { scan-ipa-dump-not "IPA_PARAM_OP_SPLIT" "sra" } } */ +/* { dg-final { scan-tree-dump " ={v} " "optimized" } } */ diff --git a/gcc/testsuite/gcc.dg/loop-8.c b/gcc/testsuite/gcc.dg/loop-8.c index 90ea1c4..a685fc2 100644 --- a/gcc/testsuite/gcc.dg/loop-8.c +++ b/gcc/testsuite/gcc.dg/loop-8.c @@ -11,18 +11,23 @@ f (int *a, int *b) { int i; - for (i = 0; i < 100; i++) + i = 100; + if (i > 0) { - int d = 42; + do + { + int d = 42; - a[i] = d; - if (i % 2) - d = i; - b[i] = d; + a[i] = d; + if (i % 2) + d = i; + b[i] = d; + ++i; + } + while (i < 100); } } /* Load of 42 is moved out of the loop, introducing a new pseudo register. */ -/* { dg-final { scan-rtl-dump-times "Decided" 1 "loop2_invariant" } } */ /* { dg-final { scan-rtl-dump-not "without introducing a new temporary register" "loop2_invariant" } } */ diff --git a/gcc/testsuite/gcc.dg/optimize-bswapsi-5.c b/gcc/testsuite/gcc.dg/optimize-bswapsi-5.c index 91a5284..5934aac 100644 --- a/gcc/testsuite/gcc.dg/optimize-bswapsi-5.c +++ b/gcc/testsuite/gcc.dg/optimize-bswapsi-5.c @@ -1,6 +1,6 @@ /* { dg-do compile } */ /* { dg-require-effective-target bswap } */ -/* { dg-options "-O2 -fdump-tree-optimized -fno-inline-functions" } */ +/* { dg-options "-O2 -fno-tree-vectorize -fdump-tree-optimized -fno-inline-functions" } */ /* { dg-additional-options "-march=z900" { target s390-*-* } } */ struct L { unsigned int l[2]; }; diff --git a/gcc/testsuite/gcc.dg/optimize-bswapsi-6.c b/gcc/testsuite/gcc.dg/optimize-bswapsi-6.c index 3c089b3..75f8aec 100644 --- a/gcc/testsuite/gcc.dg/optimize-bswapsi-6.c +++ b/gcc/testsuite/gcc.dg/optimize-bswapsi-6.c @@ -1,7 +1,7 @@ /* PR tree-optimization/42587 */ /* { dg-do compile } */ /* { dg-require-effective-target bswap } */ -/* { dg-options "-O2 -fdump-tree-store-merging" } */ +/* { dg-options "-O2 -fno-tree-vectorize -fdump-tree-store-merging" } */ /* { dg-additional-options "-march=z900" { target s390-*-* } } */ typedef unsigned char u8; diff --git a/gcc/testsuite/gcc.dg/plugin/gil-1.c b/gcc/testsuite/gcc.dg/plugin/gil-1.c index 66872f0..6cbc197 100644 --- a/gcc/testsuite/gcc.dg/plugin/gil-1.c +++ b/gcc/testsuite/gcc.dg/plugin/gil-1.c @@ -1,5 +1,6 @@ /* { dg-do compile } */ /* { dg-options "-fanalyzer" } */ +/* { dg-require-effective-target analyzer } */ #include "gil.h" diff --git a/gcc/testsuite/gcc.dg/pr102385.c b/gcc/testsuite/gcc.dg/pr102385.c new file mode 100644 index 0000000..1339540 --- /dev/null +++ b/gcc/testsuite/gcc.dg/pr102385.c @@ -0,0 +1,14 @@ +/* { dg-options "-Wall -Wextra -O2 -fno-toplevel-reorder -fno-tree-ch -fno-tree-dce -fno-tree-dominator-opts -fno-tree-dse -fno-tree-loop-ivcanon -fpredictive-commoning" } */ + +short a, b; +int c[9]; +void(d)() {} +void e() { + a = 0; + for (; a <= 4; a++) { + short *f = &b; + c[a] || (*f = 0); + d(c[a + 2]); + } +} +int main() {return 0;} diff --git a/gcc/testsuite/gcc.dg/pr102585.c b/gcc/testsuite/gcc.dg/pr102585.c new file mode 100644 index 0000000..efd066b --- /dev/null +++ b/gcc/testsuite/gcc.dg/pr102585.c @@ -0,0 +1,6 @@ +/* PR debug/102585 */ +/* { dg-do compile } */ +/* { dg-options "-fvar-tracking-assignments -fno-var-tracking" } */ + +#pragma GCC optimize 0 +void d_demangle_callback_Og() { int c = 0; } diff --git a/gcc/testsuite/gcc.dg/pr102738.c b/gcc/testsuite/gcc.dg/pr102738.c new file mode 100644 index 0000000..cd58c25 --- /dev/null +++ b/gcc/testsuite/gcc.dg/pr102738.c @@ -0,0 +1,49 @@ +/* PR tree-optimization/102738 */ +/* { dg-options "-O2 -fdump-tree-evrp" } */ +/* { dg-do compile { target int128 } } */ + +/* Remove arithmetic shift right when the LHS is known to be 0 or -1. */ + +int a1(__int128 f, int g) +{ + /* Leaves f >> 127. */ + return (f >> 127) >> g; +} + +int a2(int f, int g) +{ + /* Leaves f >> 31. */ + return (f >> 31) >> g; +} + +int a3(int f, int g) +{ + if (f == 0 || f == -1) + return f >> g; + __builtin_unreachable(); +} + +int a4(int f, int g) +{ + if (f == 0 || f == 1) + return (-f) >> g; + __builtin_unreachable(); +} + +int a5(int f, int g) +{ + if (f == 0 || f == 1) + return (f-1) >> g; + return 0; +} + +int a6(int f, int g) +{ + if (f == 6 || f == 7) + return (f-7) >> g; + __builtin_unreachable(); +} + +/* { dg-final { scan-tree-dump-times " >> 127" 1 "evrp" } } */ +/* { dg-final { scan-tree-dump-times " >> 31" 1 "evrp" } } */ +/* { dg-final { scan-tree-dump-times " >> " 2 "evrp" } } */ diff --git a/gcc/testsuite/gcc.dg/pr102764.c b/gcc/testsuite/gcc.dg/pr102764.c new file mode 100644 index 0000000..ea1c634 --- /dev/null +++ b/gcc/testsuite/gcc.dg/pr102764.c @@ -0,0 +1,14 @@ +/* PR middle-end/102764 */ +/* Reported by Chengnian Sun <cnsun@uwaterloo.ca> */ + +/* { dg-do compile } */ +/* { dg-options "-O3 -fcompare-debug" } */ + +volatile int a; + +void main (void) +{ + for (int i = 0; i < 1000; i++) + if (i % 17) + a++; +} diff --git a/gcc/testsuite/gcc.dg/pr102798.c b/gcc/testsuite/gcc.dg/pr102798.c new file mode 100644 index 0000000..3a50546 --- /dev/null +++ b/gcc/testsuite/gcc.dg/pr102798.c @@ -0,0 +1,41 @@ +/* { dg-do run } */ +/* { dg-options "-O3 -fno-tree-pta" } */ + +typedef __SIZE_TYPE__ size_t; + +__attribute__((__noipa__)) +void BUF_reverse (unsigned char *out, const unsigned char *in, size_t size) +{ + size_t i; + if (in) + { + out += size - 1; + for (i = 0; i < size; i++) + *out++ = *in++; + } + else + { + unsigned char *q; + char c; + q = out + size - 1; + for (i = 0; i < size ; i++) + { + *out++ = 1; + } + } +} + +int +main (void) +{ + unsigned char buf[40]; + unsigned char buf1[40]; + for (unsigned i = 0; i < sizeof (buf); i++) + buf[i] = i; + BUF_reverse (buf, 0, sizeof (buf)); + for (unsigned i = 0; i < sizeof (buf); i++) + if (buf[i] != 1) + __builtin_abort (); + + return 0; +} diff --git a/gcc/testsuite/gcc.dg/pr102827.c b/gcc/testsuite/gcc.dg/pr102827.c new file mode 100644 index 0000000..eed3eba --- /dev/null +++ b/gcc/testsuite/gcc.dg/pr102827.c @@ -0,0 +1,13 @@ +/* { dg-do compile } */ +/* { dg-options "-O -ftree-vectorize --param ssa-name-def-chain-limit=0" } */ +/* { dg-additional-options "-mavx" { target { x86_64-*-* i?86-*-* } } } */ + +void +test_double_double_nugt_var (double *dest, double *src, int b, int i) +{ + while (i < 1) + { + dest[i] = b ? src[i] : 0.0; + ++i; + } +} diff --git a/gcc/testsuite/gcc.dg/pr102897.c b/gcc/testsuite/gcc.dg/pr102897.c new file mode 100644 index 0000000..8e0d25e --- /dev/null +++ b/gcc/testsuite/gcc.dg/pr102897.c @@ -0,0 +1,16 @@ +/* { dg-do compile } */ +/* Specify C99 to avoid the warning/error on compound literals. */ +/* { dg-options "-O1 -std=c99 -Wno-psabi" } */ + +/* Verify that there is no ICE. */ + +typedef __attribute__((vector_size(8))) signed char int8x8_t; +typedef __attribute__((vector_size(8))) unsigned char uint8x8_t; + +int8x8_t fn1 (int8x8_t val20, char tmp) +{ + uint8x8_t __trans_tmp_3; + __trans_tmp_3 = (uint8x8_t){tmp}; + int8x8_t __a = (int8x8_t) __trans_tmp_3; + return __builtin_shuffle (__a, val20, (uint8x8_t){0}); +} diff --git a/gcc/testsuite/gcc.dg/pr36902.c b/gcc/testsuite/gcc.dg/pr36902.c index 7dafc9a..365a26e 100644 --- a/gcc/testsuite/gcc.dg/pr36902.c +++ b/gcc/testsuite/gcc.dg/pr36902.c @@ -24,10 +24,9 @@ struct { unsigned char pcr_select[4]; } sel; +unsigned char buf[64]; int bar(void) { - static unsigned char buf[64]; - sel.size_of_select = 3; foo(buf, sel.pcr_select, sel.size_of_select); @@ -52,8 +51,6 @@ foo2(unsigned char * to, const unsigned char * from, int n) int baz(void) { - static unsigned char buf[64]; - sel.size_of_select = 5; foo2(buf, sel.pcr_select, sel.size_of_select); diff --git a/gcc/testsuite/gcc.dg/shrink-wrap-loop.c b/gcc/testsuite/gcc.dg/shrink-wrap-loop.c index 6e1be893..ddc99e6 100644 --- a/gcc/testsuite/gcc.dg/shrink-wrap-loop.c +++ b/gcc/testsuite/gcc.dg/shrink-wrap-loop.c @@ -1,58 +1,6 @@ /* { dg-do compile { target { { { i?86-*-* x86_64-*-* } && lp64 } || { arm_thumb2 } } } } */ /* { dg-options "-O2 -fdump-rtl-pro_and_epilogue" } */ -/* -Our new threader is threading things a bit too early, and causing the -testcase in gcc.dg/shrink-wrap-loop.c to fail. - - The gist is this BB inside a loop: - - <bb 6> : - # p_2 = PHI <p2_6(D)(2), p_12(5)> - if (p_2 != 0B) - goto <bb 3>; [INV] - else - goto <bb 7>; [INV] - -Our threader can move this check outside of the loop (good). This is -done before branch probabilities are calculated and causes the probs -to be calculated as: - -<bb 2> [local count: 216361238]: - if (p2_6(D) != 0B) - goto <bb 7>; [54.59%] - else - goto <bb 6>; [45.41%] - -Logically this seems correct to me. A simple check outside of a loop -should slightly but not overwhelmingly favor a non-zero value. - -Interestingly however, the old threader couldn't get this, but the IL -ended up identical, albeit with different probabilities. What happens -is that, because the old code could not thread this, the p2 != 0 check -would remain inside the loop and probs would be calculated thusly: - - <bb 6> [local count: 1073741824]: - # p_2 = PHI <p2_6(D)(2), p_12(5)> - if (p_2 != 0B) - goto <bb 3>; [94.50%] - else - goto <bb 7>; [5.50%] - -Then when the loop header copying pass ("ch") shuffled things around, -the IL would end up identical to my early threader code, but with the -probabilities would remain as 94.5/5.5. - -The above discrepancy causes the RTL ifcvt pass to generate different -code, and by the time we get to the shrink wrapping pass, things look -sufficiently different such that the legacy code can actually shrink -wrap, whereas our new code does not. - -IMO, if the loop-ch pass moves conditionals outside of a loop, the -probabilities should be adjusted, but that does mean the shrink wrap -won't happen for this contrived testcase. - */ - int foo (int *p1, int *p2); int @@ -68,4 +16,4 @@ test (int *p1, int *p2) return 1; } -/* { dg-final { scan-rtl-dump "Performing shrink-wrapping" "pro_and_epilogue" { xfail *-*-* } } } */ +/* { dg-final { scan-rtl-dump "Performing shrink-wrapping" "pro_and_epilogue" } } */ diff --git a/gcc/testsuite/gcc.dg/torture/pr102762.c b/gcc/testsuite/gcc.dg/torture/pr102762.c new file mode 100644 index 0000000..67c6b00 --- /dev/null +++ b/gcc/testsuite/gcc.dg/torture/pr102762.c @@ -0,0 +1,11 @@ +/* { dg-do compile } */ +/* We fail to diagnose the invalid __builtin_va_arg_pack use with -flto. */ +/* { dg-skip-if "" { *-*-* } { "-flto" } { "" } } */ + +void log_bad_request(); +void foo(a, b) + int a, b; +{ + log_bad_request(0, __builtin_va_arg_pack()); /* { dg-error "invalid use" } */ + foo(0); +} diff --git a/gcc/testsuite/gcc.dg/torture/pr102920.c b/gcc/testsuite/gcc.dg/torture/pr102920.c new file mode 100644 index 0000000..aa27ac5 --- /dev/null +++ b/gcc/testsuite/gcc.dg/torture/pr102920.c @@ -0,0 +1,25 @@ +/* { dg-do run } */ +/* { dg-additional-options "-funswitch-loops" } */ + +unsigned short a = 42; +unsigned short b = 1; +long int c = 1; +unsigned char var_120; +unsigned char var_123; + +void __attribute__((noipa)) test(unsigned short a, unsigned short b, long c) +{ + for (char i = 0; i < (char)c; i += 5) + if (!b) + var_120 = a; + else + var_123 = a; +} + +int main() +{ + test(a, b, c); + if (var_123 != 42) + __builtin_abort (); + return 0; +} diff --git a/gcc/testsuite/gcc.dg/torture/pr69760.c b/gcc/testsuite/gcc.dg/torture/pr69760.c index 53733c7..47e01ae 100644 --- a/gcc/testsuite/gcc.dg/torture/pr69760.c +++ b/gcc/testsuite/gcc.dg/torture/pr69760.c @@ -1,11 +1,10 @@ /* PR tree-optimization/69760 */ /* { dg-do run { target { { *-*-linux* *-*-gnu* *-*-uclinux* } && mmap } } } */ -/* { dg-options "-O2" } */ #include <unistd.h> #include <sys/mman.h> -__attribute__((noinline, noclone)) void +__attribute__((noinline, noclone)) static void test_func (double *a, int L, int m, int n, int N) { int i, k; diff --git a/gcc/testsuite/gcc.dg/torture/ssa-pta-fn-1.c b/gcc/testsuite/gcc.dg/torture/ssa-pta-fn-1.c index 1f30467..de019a7 100644 --- a/gcc/testsuite/gcc.dg/torture/ssa-pta-fn-1.c +++ b/gcc/testsuite/gcc.dg/torture/ssa-pta-fn-1.c @@ -6,13 +6,13 @@ extern void abort (void); int *g; int dummy; -int * __attribute__((noinline,const)) +int * __attribute__((noinline,const,noipa)) foo_const(int *p) { return p; } -int * __attribute__((noinline,pure)) +int * __attribute__((noinline,pure,noipa)) foo_pure(int *p) { return p + dummy; } -int * __attribute__((noinline)) +int * __attribute__((noinline,noipa)) foo_normal(int *p) { g = p; return p; } void test_const(void) @@ -58,4 +58,4 @@ int main() /* { dg-final { scan-tree-dump "q_const_. = { NONLOCAL i }" "alias" } } */ /* { dg-final { scan-tree-dump "q_pure_. = { ESCAPED NONLOCAL i }" "alias" } } */ -/* { dg-final { scan-tree-dump "q_normal_. = { ESCAPED NONLOCAL }" "alias" } } */ +/* { dg-final { scan-tree-dump "q_normal_. = { ESCAPED NONLOCAL i }" "alias" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/builtin-sprintf-warn-23.c b/gcc/testsuite/gcc.dg/tree-ssa/builtin-sprintf-warn-23.c index 7fb9651..112b08a 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/builtin-sprintf-warn-23.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/builtin-sprintf-warn-23.c @@ -214,12 +214,14 @@ void test_struct_member_array (struct S3 *s3, int i) T (d, "%s", d); /* { dg-warning "overlaps" } */ T (d, "%s", d + 0); /* { dg-warning "overlaps" } */ T (d, "%s", d + 1); /* { dg-warning "may overlap" } */ - T (d, "%s", d + 2); /* { dg-warning "may overlap" } */ + /* Since d below points to char[4], strlen(d + 2) must be at most 1 + and so the call cannot overlap. */ + T (d, "%s", d + 2); T (d, "%s", d + i); /* { dg-warning "may overlap" } */ T (d, "%s", &d[0]); /* { dg-warning "overlaps" } */ T (d, "%s", &d[1]); /* { dg-warning "may overlap" } */ - T (d, "%s", &d[2]); /* { dg-warning "may overlap" } */ + T (d, "%s", &d[2]); T (d, "%s", &d[i]); /* { dg-warning "may overlap" } */ T (d + 0, "%s", d); /* { dg-warning "overlaps" } */ @@ -236,7 +238,7 @@ void test_struct_member_array (struct S3 *s3, int i) T (d, "%s", s); /* { dg-warning "overlaps" } */ T (d, "%s", s + 1); /* { dg-warning "may overlap" } */ - T (d, "%s", s + 2); /* { dg-warning "may overlap" } */ + T (d, "%s", s + 2); T (d, "%s", s + i); /* { dg-warning "may overlap" } */ s = s3->s2_1.s_1.b; @@ -324,7 +326,7 @@ void test_struct_member_array (struct S3 *s3, int i) T (d, "%s", s); /* { dg-warning "overlaps" } */ T (d, "%s", s + 1); /* { dg-warning "may overlap" } */ - T (d, "%s", s + 2); /* { dg-warning "may overlap" } */ + T (d, "%s", s + 2); T (d, "%s", s + i); /* { dg-warning "may overlap" } */ s = s3->s2_2.s_2.a; @@ -368,7 +370,7 @@ void test_struct_member_array (struct S3 *s3, int i) T (d, "%s", s); /* { dg-warning "overlaps" } */ T (d, "%s", s + 1); /* { dg-warning "may overlap" } */ - T (d, "%s", s + 2); /* { dg-warning "may overlap" } */ + T (d, "%s", s + 2); T (d, "%s", s + i); /* { dg-warning "may overlap" } */ s = s3->s2_2.s_2.a; @@ -394,12 +396,12 @@ void test_struct_member_array_array (struct S3 *s3, int i) T (d, "%s", s); /* { dg-warning "overlaps" } */ T (d, "%s", s + 0); /* { dg-warning "overlaps" } */ T (d, "%s", s + 1); /* { dg-warning "may overlap" } */ - T (d, "%s", s + 2); /* { dg-warning "may overlap" } */ + T (d, "%s", s + 2); T (d, "%s", s + i); /* { dg-warning "may overlap" } */ T (d, "%s", &s[0]); /* { dg-warning "overlaps" } */ T (d, "%s", &s[1]); /* { dg-warning "may overlap" } */ - T (d, "%s", &s[2]); /* { dg-warning "may overlap" } */ + T (d, "%s", &s[2]); T (d, "%s", &s[i]); /* { dg-warning "may overlap" } */ T (d + 0, "%s", s); /* { dg-warning "overlaps" } */ @@ -566,12 +568,12 @@ void test_union_member_array (union U *un, int i) T (d, "%s", d); /* { dg-warning "overlaps" } */ T (d, "%s", d + 0); /* { dg-warning "overlaps" } */ T (d, "%s", d + 1); /* { dg-warning "may overlap" } */ - T (d, "%s", d + 2); /* { dg-warning "may overlap" } */ + T (d, "%s", d + 2); T (d, "%s", d + i); /* { dg-warning "may overlap" } */ T (d, "%s", &d[0]); /* { dg-warning "overlaps" } */ T (d, "%s", &d[1]); /* { dg-warning "may overlap" } */ - T (d, "%s", &d[2]); /* { dg-warning "may overlap" } */ + T (d, "%s", &d[2]); T (d, "%s", &d[i]); /* { dg-warning "may overlap" } */ T (d + 0, "%s", d); /* { dg-warning "overlaps" } */ @@ -588,7 +590,7 @@ void test_union_member_array (union U *un, int i) T (d, "%s", s); /* { dg-warning "overlaps" } */ T (d, "%s", s + 1); /* { dg-warning "may overlap" } */ - T (d, "%s", s + 2); /* { dg-warning "may overlap" } */ + T (d, "%s", s + 2); T (d, "%s", s + i); /* { dg-warning "may overlap" } */ s = un->s2_1.s_1.b; @@ -616,7 +618,7 @@ void test_union_member_array (union U *un, int i) T (d, "%s", s); /* { dg-warning "overlaps" } */ T (d, "%s", s + 1); /* { dg-warning "may overlap" } */ - T (d, "%s", s + 2); /* { dg-warning "may overlap" } */ + T (d, "%s", s + 2); T (d, "%s", s + i); /* { dg-warning "may overlap" } */ s = un->s2_2.s_1.b; diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ifc-20040816-1.c b/gcc/testsuite/gcc.dg/tree-ssa/ifc-20040816-1.c index b55a533..f8a6495 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/ifc-20040816-1.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/ifc-20040816-1.c @@ -39,4 +39,4 @@ int main1 () which is folded by vectorizer. Both outgoing edges must have probability 100% so the resulting profile match after folding. */ /* { dg-final { scan-tree-dump-times "Invalid sum of outgoing probabilities 200.0" 1 "ifcvt" } } */ -/* { dg-final { scan-tree-dump-times "Invalid sum of incoming counts" 1 "ifcvt" } } */ +/* { dg-final { scan-tree-dump-times "Invalid sum of incoming counts" 2 "ifcvt" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ldist-rawmemchr-1.c b/gcc/testsuite/gcc.dg/tree-ssa/ldist-rawmemchr-1.c new file mode 100644 index 0000000..6abfd27 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/ldist-rawmemchr-1.c @@ -0,0 +1,72 @@ +/* { dg-do run { target s390x-*-* } } */ +/* { dg-options "-O2 -ftree-loop-distribution -fdump-tree-ldist-details" } */ +/* { dg-final { scan-tree-dump-times "generated rawmemchrQI" 2 "ldist" { target s390x-*-* } } } */ +/* { dg-final { scan-tree-dump-times "generated rawmemchrHI" 2 "ldist" { target s390x-*-* } } } */ +/* { dg-final { scan-tree-dump-times "generated rawmemchrSI" 2 "ldist" { target s390x-*-* } } } */ + +/* Rawmemchr pattern: reduction stmt and no store */ + +#include <stdint.h> +#include <assert.h> + +typedef __SIZE_TYPE__ size_t; +extern void* malloc (size_t); +extern void* memset (void*, int, size_t); + +#define test(T, pattern) \ +__attribute__((noinline)) \ +T *test_##T (T *p) \ +{ \ + while (*p != (T)pattern) \ + ++p; \ + return p; \ +} + +test (uint8_t, 0xab) +test (uint16_t, 0xabcd) +test (uint32_t, 0xabcdef15) + +test (int8_t, 0xab) +test (int16_t, 0xabcd) +test (int32_t, 0xabcdef15) + +#define run(T, pattern, i) \ +{ \ +T *q = p; \ +q[i] = (T)pattern; \ +assert (test_##T (p) == &q[i]); \ +q[i] = 0; \ +} + +int main(void) +{ + void *p = malloc (1024); + assert (p); + memset (p, 0, 1024); + + run (uint8_t, 0xab, 0); + run (uint8_t, 0xab, 1); + run (uint8_t, 0xab, 13); + + run (uint16_t, 0xabcd, 0); + run (uint16_t, 0xabcd, 1); + run (uint16_t, 0xabcd, 13); + + run (uint32_t, 0xabcdef15, 0); + run (uint32_t, 0xabcdef15, 1); + run (uint32_t, 0xabcdef15, 13); + + run (int8_t, 0xab, 0); + run (int8_t, 0xab, 1); + run (int8_t, 0xab, 13); + + run (int16_t, 0xabcd, 0); + run (int16_t, 0xabcd, 1); + run (int16_t, 0xabcd, 13); + + run (int32_t, 0xabcdef15, 0); + run (int32_t, 0xabcdef15, 1); + run (int32_t, 0xabcdef15, 13); + + return 0; +} diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ldist-rawmemchr-2.c b/gcc/testsuite/gcc.dg/tree-ssa/ldist-rawmemchr-2.c new file mode 100644 index 0000000..00d6ea0 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/ldist-rawmemchr-2.c @@ -0,0 +1,83 @@ +/* { dg-do run { target s390x-*-* } } */ +/* { dg-options "-O2 -ftree-loop-distribution -fdump-tree-ldist-details" } */ +/* { dg-final { scan-tree-dump-times "generated rawmemchrQI" 2 "ldist" { target s390x-*-* } } } */ +/* { dg-final { scan-tree-dump-times "generated rawmemchrHI" 2 "ldist" { target s390x-*-* } } } */ +/* { dg-final { scan-tree-dump-times "generated rawmemchrSI" 2 "ldist" { target s390x-*-* } } } */ + +/* Rawmemchr pattern: reduction stmt and store */ + +#include <stdint.h> +#include <assert.h> + +typedef __SIZE_TYPE__ size_t; +extern void* malloc (size_t); +extern void* memset (void*, int, size_t); + +uint8_t *p_uint8_t; +uint16_t *p_uint16_t; +uint32_t *p_uint32_t; + +int8_t *p_int8_t; +int16_t *p_int16_t; +int32_t *p_int32_t; + +#define test(T, pattern) \ +__attribute__((noinline)) \ +T *test_##T (void) \ +{ \ + while (*p_##T != pattern) \ + ++p_##T; \ + return p_##T; \ +} + +test (uint8_t, 0xab) +test (uint16_t, 0xabcd) +test (uint32_t, 0xabcdef15) + +test (int8_t, (int8_t)0xab) +test (int16_t, (int16_t)0xabcd) +test (int32_t, (int32_t)0xabcdef15) + +#define run(T, pattern, i) \ +{ \ +T *q = p; \ +q[i] = pattern; \ +p_##T = p; \ +T *r = test_##T (); \ +assert (r == p_##T); \ +assert (r == &q[i]); \ +q[i] = 0; \ +} + +int main(void) +{ + void *p = malloc (1024); + assert (p); + memset (p, '\0', 1024); + + run (uint8_t, 0xab, 0); + run (uint8_t, 0xab, 1); + run (uint8_t, 0xab, 13); + + run (uint16_t, 0xabcd, 0); + run (uint16_t, 0xabcd, 1); + run (uint16_t, 0xabcd, 13); + + run (uint32_t, 0xabcdef15, 0); + run (uint32_t, 0xabcdef15, 1); + run (uint32_t, 0xabcdef15, 13); + + run (int8_t, (int8_t)0xab, 0); + run (int8_t, (int8_t)0xab, 1); + run (int8_t, (int8_t)0xab, 13); + + run (int16_t, (int16_t)0xabcd, 0); + run (int16_t, (int16_t)0xabcd, 1); + run (int16_t, (int16_t)0xabcd, 13); + + run (int32_t, (int32_t)0xabcdef15, 0); + run (int32_t, (int32_t)0xabcdef15, 1); + run (int32_t, (int32_t)0xabcdef15, 13); + + return 0; +} diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ldist-strlen-1.c b/gcc/testsuite/gcc.dg/tree-ssa/ldist-strlen-1.c new file mode 100644 index 0000000..918b600 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/ldist-strlen-1.c @@ -0,0 +1,100 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -ftree-loop-distribution -fdump-tree-ldist-details" } */ +/* { dg-final { scan-tree-dump-times "generated strlenQI\n" 4 "ldist" } } */ +/* { dg-final { scan-tree-dump-times "generated strlenHI\n" 4 "ldist" { target s390x-*-* } } } */ +/* { dg-final { scan-tree-dump-times "generated strlenSI\n" 4 "ldist" { target s390x-*-* } } } */ + +#include <stdint.h> +#include <assert.h> + +typedef __SIZE_TYPE__ size_t; +extern void* malloc (size_t); +extern void* memset (void*, int, size_t); + +#define test(T, U) \ +__attribute__((noinline)) \ +U test_##T##U (T *s) \ +{ \ + U i; \ + for (i=0; s[i]; ++i); \ + return i; \ +} + +test (uint8_t, size_t) +test (uint16_t, size_t) +test (uint32_t, size_t) +test (uint8_t, int) +test (uint16_t, int) +test (uint32_t, int) + +test (int8_t, size_t) +test (int16_t, size_t) +test (int32_t, size_t) +test (int8_t, int) +test (int16_t, int) +test (int32_t, int) + +#define run(T, U, i) \ +{ \ +T *q = p; \ +q[i] = 0; \ +assert (test_##T##U (p) == i); \ +memset (&q[i], 0xf, sizeof (T)); \ +} + +int main(void) +{ + void *p = malloc (1024); + assert (p); + memset (p, 0xf, 1024); + + run (uint8_t, size_t, 0); + run (uint8_t, size_t, 1); + run (uint8_t, size_t, 13); + + run (int8_t, size_t, 0); + run (int8_t, size_t, 1); + run (int8_t, size_t, 13); + + run (uint8_t, int, 0); + run (uint8_t, int, 1); + run (uint8_t, int, 13); + + run (int8_t, int, 0); + run (int8_t, int, 1); + run (int8_t, int, 13); + + run (uint16_t, size_t, 0); + run (uint16_t, size_t, 1); + run (uint16_t, size_t, 13); + + run (int16_t, size_t, 0); + run (int16_t, size_t, 1); + run (int16_t, size_t, 13); + + run (uint16_t, int, 0); + run (uint16_t, int, 1); + run (uint16_t, int, 13); + + run (int16_t, int, 0); + run (int16_t, int, 1); + run (int16_t, int, 13); + + run (uint32_t, size_t, 0); + run (uint32_t, size_t, 1); + run (uint32_t, size_t, 13); + + run (int32_t, size_t, 0); + run (int32_t, size_t, 1); + run (int32_t, size_t, 13); + + run (uint32_t, int, 0); + run (uint32_t, int, 1); + run (uint32_t, int, 13); + + run (int32_t, int, 0); + run (int32_t, int, 1); + run (int32_t, int, 13); + + return 0; +} diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ldist-strlen-2.c b/gcc/testsuite/gcc.dg/tree-ssa/ldist-strlen-2.c new file mode 100644 index 0000000..e25d6ea --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/ldist-strlen-2.c @@ -0,0 +1,58 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -ftree-loop-distribution -fdump-tree-ldist-details" } */ +/* { dg-final { scan-tree-dump-times "generated strlenQI\n" 3 "ldist" } } */ + +#include <assert.h> + +typedef __SIZE_TYPE__ size_t; +extern void* malloc (size_t); +extern void* memset (void*, int, size_t); + +__attribute__((noinline)) +int test_pos (char *s) +{ + int i; + for (i=42; s[i]; ++i); + return i; +} + +__attribute__((noinline)) +int test_neg (char *s) +{ + int i; + for (i=-42; s[i]; ++i); + return i; +} + +__attribute__((noinline)) +int test_including_null_char (char *s) +{ + int i; + for (i=1; s[i-1]; ++i); + return i; +} + +int main(void) +{ + void *p = malloc (1024); + assert (p); + memset (p, 0xf, 1024); + char *s = (char *)p + 100; + + s[42+13] = 0; + assert (test_pos (s) == 42+13); + s[42+13] = 0xf; + + s[13] = 0; + assert (test_neg (s) == 13); + s[13] = 0xf; + + s[-13] = 0; + assert (test_neg (s) == -13); + s[-13] = 0xf; + + s[13] = 0; + assert (test_including_null_char (s) == 13+1); + + return 0; +} diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ldist-strlen-3.c b/gcc/testsuite/gcc.dg/tree-ssa/ldist-strlen-3.c new file mode 100644 index 0000000..370fd5e --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/ldist-strlen-3.c @@ -0,0 +1,12 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -ftree-loop-distribution -fdump-tree-ldist-details" } */ +/* { dg-final { scan-tree-dump-times "generated strlenSI\n" 1 "ldist" { target s390x-*-* } } } */ + +extern int s[]; + +int test () +{ + int i = 0; + for (; s[i]; ++i); + return i; +} diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr102736.c b/gcc/testsuite/gcc.dg/tree-ssa/pr102736.c new file mode 100644 index 0000000..c693a71 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr102736.c @@ -0,0 +1,21 @@ +// { dg-do run } +// { dg-options "-O1 -ftree-vrp" } + +int a, b = -1, c; +int d = 1; +static inline signed char e(signed char f, int g) { return g ? f : 0; } +static inline signed char h(signed char f) { return f < a ? f : f < a; } +static inline unsigned char i(unsigned char f, int g) { return g ? f : f > g; } +void j() { +L: + c = e(1, i(h(b), d)); + if (b) + return; + goto L; +} +int main() { + j(); + if (c != 1) + __builtin_abort (); + return 0; +} diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr20701.c b/gcc/testsuite/gcc.dg/tree-ssa/pr20701.c index 2f91458..496c425 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/pr20701.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr20701.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-O2 -fdump-tree-vrp1 -fno-early-inlining -fdelete-null-pointer-checks" } */ +/* { dg-options "-O2 -fdump-tree-vrp1 -fno-early-inlining -fdelete-null-pointer-checks -fdisable-tree-thread1" } */ typedef struct { int code; diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr20702.c b/gcc/testsuite/gcc.dg/tree-ssa/pr20702.c index c8968577..8112967 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/pr20702.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr20702.c @@ -4,7 +4,7 @@ immediate successors of the basic block. */ /* { dg-do compile } */ -/* { dg-options "-O2 -fno-tree-dominator-opts -fdisable-tree-evrp -fdump-tree-vrp1-details -fdelete-null-pointer-checks" } */ +/* { dg-options "-O2 -fno-thread-jumps -fdisable-tree-evrp -fdump-tree-vrp1-details -fdelete-null-pointer-checks" } */ extern void bar (int); diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr21086.c b/gcc/testsuite/gcc.dg/tree-ssa/pr21086.c index aadd53e..9b93d39 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/pr21086.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr21086.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-O2 -fdisable-tree-evrp -fdump-tree-vrp1 -fdump-tree-dce2 -fdelete-null-pointer-checks" } */ +/* { dg-options "-O2 -fno-thread-jumps -fdisable-tree-evrp -fdump-tree-vrp1 -fdump-tree-dce2 -fdelete-null-pointer-checks" } */ int foo (int *p) diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr21090.c b/gcc/testsuite/gcc.dg/tree-ssa/pr21090.c index 3909adb..92a8768 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/pr21090.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr21090.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-O2 -fdisable-tree-evrp -fdump-tree-vrp1 -fdelete-null-pointer-checks" } */ +/* { dg-options "-O2 -fno-thread-jumps -fdisable-tree-evrp -fdump-tree-vrp1 -fdelete-null-pointer-checks" } */ int g, h; diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr21559.c b/gcc/testsuite/gcc.dg/tree-ssa/pr21559.c index 51b3b7a..43f046e 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/pr21559.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr21559.c @@ -35,10 +35,7 @@ void foo (void) /* First, we should simplify the bits < 0 test within the loop. */ /* { dg-final { scan-tree-dump-times "Simplified relational" 1 "evrp" } } */ -/* Second, we should thread the edge out of the loop via the break - statement. We also realize that the final bytes == 0 test is useless, - and thread over it. We also know that toread != 0 is useless when - entering while loop and thread over it. */ -/* { dg-final { scan-tree-dump-times "Threaded jump" 3 "vrp-thread1" } } */ +/* We used to check for 3 threaded jumps here, but they all would + rotate the loop. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr25382.c b/gcc/testsuite/gcc.dg/tree-ssa/pr25382.c index d747655..8634c0a 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/pr25382.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr25382.c @@ -3,7 +3,7 @@ Check that VRP now gets ranges from BIT_AND_EXPRs. */ /* { dg-do compile } */ -/* { dg-options "-O2 -fno-tree-ccp -fdisable-tree-evrp -fdump-tree-vrp1" } */ +/* { dg-options "-O2 -fno-thread-jumps -fno-tree-ccp -fdisable-tree-evrp -fdump-tree-vrp1" } */ int foo (int a) diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr58480.c b/gcc/testsuite/gcc.dg/tree-ssa/pr58480.c index 42898e7..f11623b 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/pr58480.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr58480.c @@ -1,5 +1,5 @@ /* { dg-do compile { target { ! keeps_null_pointer_checks } } } */ -/* { dg-options "-O2 -fdisable-tree-evrp -fdump-tree-vrp1 -fdelete-null-pointer-checks" } */ +/* { dg-options "-O2 -fno-thread-jumps -fdisable-tree-evrp -fdump-tree-vrp1 -fdelete-null-pointer-checks" } */ extern void eliminate (void); extern void* f1 (void *a, void *b) __attribute__((nonnull)); diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr59597.c b/gcc/testsuite/gcc.dg/tree-ssa/pr59597.c index 2caa1f5..764b3fe 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/pr59597.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr59597.c @@ -56,11 +56,7 @@ main (int argc, char argv[]) return crc; } -/* Previously we had 3 jump threads, but one of them crossed loops. - The reason the old threader was allowing it, was because there was - an ASSERT_EXPR getting in the way. Without the ASSERT_EXPR, we - have an empty pre-header block as the final block in the thread, - which the threader will simply join with the next block which *is* - in a different loop. */ -/* { dg-final { scan-tree-dump-times "Registering jump thread" 2 "vrp-thread1" } } */ +/* None of the threads we can get in vrp-thread1 are valid. They all + cross or rotate loops. */ +/* { dg-final { scan-tree-dump-not "Registering jump thread" "vrp-thread1" } } */ /* { dg-final { scan-tree-dump-not "joiner" "vrp-thread1" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr71437.c b/gcc/testsuite/gcc.dg/tree-ssa/pr71437.c index a2386ba..eab3a25 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/pr71437.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr71437.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-ffast-math -O3 -fdump-tree-vrp-thread1-details" } */ +/* { dg-options "-ffast-math -O3 -fdump-tree-dom3-details" } */ int I = 50, J = 50; int S, L; @@ -39,4 +39,8 @@ void foo (int K) bar (LD, SD); } } -/* { dg-final { scan-tree-dump-times "Threaded jump " 2 "vrp-thread1" } } */ + +/* We used to get 1 vrp-thread1 candidates here, but they now get + deferred until after loop opts are done, because they were rotating + loops. */ +/* { dg-final { scan-tree-dump-times "Threaded jump " 2 "dom3" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr77445-2.c b/gcc/testsuite/gcc.dg/tree-ssa/pr77445-2.c index 18f7aab..f2a5e78 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/pr77445-2.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr77445-2.c @@ -123,8 +123,7 @@ enum STATES FMS( u8 **in , u32 *transitions) { aarch64 has the highest CASE_VALUES_THRESHOLD in GCC. It's high enough to change decisions in switch expansion which in turn can expose new jump threading opportunities. Skip the later tests on aarch64. */ -/* { dg-final { scan-tree-dump "Jumps threaded: \[7-9\]" "thread1" } } */ -/* { dg-final { scan-tree-dump-times "Invalid sum" 1 "thread1" } } */ +/* { dg-final { scan-tree-dump "Jumps threaded: \[7-9\]" "thread2" } } */ /* { dg-final { scan-tree-dump-not "optimizing for size" "thread1" } } */ /* { dg-final { scan-tree-dump-not "optimizing for size" "thread2" } } */ /* { dg-final { scan-tree-dump-not "optimizing for size" "thread3" { target { ! aarch64*-*-* } } } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/predcom-3.c b/gcc/testsuite/gcc.dg/tree-ssa/predcom-3.c index 1174cd1..9abbe6c 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/predcom-3.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/predcom-3.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-O2 -funroll-loops --param max-unroll-times=8 -fpredictive-commoning -fdump-tree-pcom-details -fno-tree-pre" } */ +/* { dg-options "-O2 -funroll-loops --param max-unroll-times=8 -fpredictive-commoning -fdump-tree-pcom-details -fno-tree-pre -fno-tree-loop-vectorize" } */ int a[1000], b[1000]; diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pta-callused.c b/gcc/testsuite/gcc.dg/tree-ssa/pta-callused.c index cb85ec1..aa639b4 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/pta-callused.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/pta-callused.c @@ -22,5 +22,5 @@ int bar (int b) return *foo (&q); } -/* { dg-final { scan-tree-dump "CALLUSED\\(\[0-9\]+\\) = { f.* i q }" "alias" } } */ +/* { dg-final { scan-tree-dump "CALLUSED\\(\[0-9\]+\\) = { NONLOCAL f.* i q }" "alias" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-dce-9.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-dce-9.c new file mode 100644 index 0000000..e1ffa7f --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/ssa-dce-9.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -fdump-tree-cddce1" } */ + +int main() +{ + while(1) + for(int i=0; i<9000000; i++){} +} + +/* { dg-final { scan-tree-dump-not "if" "cddce1" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-dom-thread-18.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-dom-thread-18.c deleted file mode 100644 index 0246ebf..0000000 --- a/gcc/testsuite/gcc.dg/tree-ssa/ssa-dom-thread-18.c +++ /dev/null @@ -1,27 +0,0 @@ -/* { dg-do compile } */ -/* { dg-options "-O2 -fdump-tree-vrp-thread1-details -std=gnu89 --param logical-op-non-short-circuit=0" } */ - -#include "ssa-dom-thread-4.c" - -/* On targets that define LOGICAL_OP_NON_SHORT_CIRCUIT to 0, we split both - "a_elt || b_elt" and "b_elt && kill_elt" into two conditions each, - rather than using "(var1 != 0) op (var2 != 0)". Also, as on other targets, - we duplicate the header of the inner "while" loop. There are then - 4 threading opportunities: - - 1x "!a_elt && b_elt" in the outer "while" loop - -> the start of the inner "while" loop, - skipping the known-true "b_elt" in the first condition. - 1x "!b_elt" in the first condition - -> the outer "while" loop's continuation point, - skipping the known-false "b_elt" in the second condition. - 2x "kill_elt->indx >= b_elt->indx" in the first "while" loop - -> "kill_elt->indx == b_elt->indx" in the second condition, - skipping the known-true "b_elt && kill_elt" in the second - condition. - - All the cases are picked up by VRP1 as jump threads. */ - -/* There used to be 6 jump threads found by thread1, but they all - depended on threading through distinct loops in ethread. */ -/* { dg-final { scan-tree-dump-times "Threaded" 2 "vrp-thread1" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-dom-thread-2a.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-dom-thread-2a.c deleted file mode 100644 index 8f0a12c..0000000 --- a/gcc/testsuite/gcc.dg/tree-ssa/ssa-dom-thread-2a.c +++ /dev/null @@ -1,21 +0,0 @@ -/* { dg-do compile } */ -/* { dg-options "-O2 -fdump-tree-vrp-thread1-stats -fdump-tree-dom2-stats" } */ - -void bla(); - -/* In the following case, we should be able to thread edge through - the loop header. */ - -void thread_entry_through_header (void) -{ - int i; - - for (i = 0; i < 170; i++) - bla (); -} - -/* There's a single jump thread that should be handled by the VRP - jump threading pass. */ -/* { dg-final { scan-tree-dump-times "Jumps threaded: 1" 1 "vrp-thread1"} } */ -/* { dg-final { scan-tree-dump-times "Jumps threaded: 2" 0 "vrp-thread1"} } */ -/* { dg-final { scan-tree-dump-not "Jumps threaded" "dom2"} } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-dom-thread-4.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-dom-thread-4.c deleted file mode 100644 index 46e464f..0000000 --- a/gcc/testsuite/gcc.dg/tree-ssa/ssa-dom-thread-4.c +++ /dev/null @@ -1,62 +0,0 @@ -/* { dg-do compile } */ -/* { dg-options "-O2 -fdump-tree-vrp-thread1-details -fdump-tree-dom2-details -std=gnu89 --param logical-op-non-short-circuit=1" } */ -struct bitmap_head_def; -typedef struct bitmap_head_def *bitmap; -typedef const struct bitmap_head_def *const_bitmap; -typedef unsigned long BITMAP_WORD; -typedef struct bitmap_element_def -{ - struct bitmap_element_def *next; - unsigned int indx; -} bitmap_element; - - - - - - - - - -unsigned char -bitmap_ior_and_compl (bitmap dst, const_bitmap a, const_bitmap b, - const_bitmap kill) -{ - unsigned char changed = 0; - - bitmap_element *dst_elt; - const bitmap_element *a_elt, *b_elt, *kill_elt, *dst_prev; - - while (a_elt || b_elt) - { - unsigned char new_element = 0; - - if (b_elt) - while (kill_elt && kill_elt->indx < b_elt->indx) - kill_elt = kill_elt->next; - - if (b_elt && kill_elt && kill_elt->indx == b_elt->indx - && (!a_elt || a_elt->indx >= b_elt->indx)) - { - bitmap_element tmp_elt; - unsigned ix; - - BITMAP_WORD ior = 0; - - changed = bitmap_elt_ior (dst, dst_elt, dst_prev, - a_elt, &tmp_elt, changed); - - } - - } - - - return changed; -} -/* The block starting the second conditional has 3 incoming edges, - we should thread all three, but due to a bug in the threading - code we missed the edge when the first conditional is false - (b_elt is zero, which means the second conditional is always - zero. VRP1 catches all three. */ -/* { dg-final { scan-tree-dump-times "Registering jump thread" 2 "vrp-thread1" } } */ -/* { dg-final { scan-tree-dump-times "Path crosses loops" 1 "vrp-thread1" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-dom-thread-6.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-dom-thread-6.c deleted file mode 100644 index b0a7d42..0000000 --- a/gcc/testsuite/gcc.dg/tree-ssa/ssa-dom-thread-6.c +++ /dev/null @@ -1,44 +0,0 @@ -/* { dg-do compile } */ -/* { dg-options "-O2 -fdump-tree-thread1-details -fdump-tree-thread3-details" } */ - -/* { dg-final { scan-tree-dump-times "Registering jump" 6 "thread1" } } */ -/* { dg-final { scan-tree-dump-times "Registering jump" 1 "thread3" } } */ - -int sum0, sum1, sum2, sum3; -int foo (char *s, char **ret) -{ - int state=0; - char c; - - for (; *s && state != 4; s++) - { - c = *s; - if (c == '*') - { - s++; - break; - } - switch (state) - { - case 0: - if (c == '+') - state = 1; - else if (c != '-') - sum0+=c; - break; - case 1: - if (c == '+') - state = 2; - else if (c == '-') - state = 0; - else - sum1+=c; - break; - default: - break; - } - - } - *ret = s; - return state; -} diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-dom-thread-7.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-dom-thread-7.c index 16abcde..ee17edd 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/ssa-dom-thread-7.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/ssa-dom-thread-7.c @@ -1,15 +1,15 @@ /* { dg-do compile } */ -/* { dg-options "-O2 -fdump-tree-thread1-stats -fdump-tree-thread2-stats -fdump-tree-dom2-stats -fdump-tree-thread3-stats -fdump-tree-dom3-stats -fdump-tree-vrp2-stats -fno-guess-branch-probability" } */ +/* { dg-options "-O2 -fdump-tree-dom2-stats -fdump-tree-thread3-stats -fdump-tree-dom3-stats -fdump-tree-vrp-thread2-stats -fno-guess-branch-probability" } */ -/* { dg-final { scan-tree-dump "Jumps threaded: 12" "thread1" } } */ -/* { dg-final { scan-tree-dump "Jumps threaded: 5" "thread3" { target { ! aarch64*-*-* } } } } */ /* { dg-final { scan-tree-dump-not "Jumps threaded" "dom2" } } */ /* aarch64 has the highest CASE_VALUES_THRESHOLD in GCC. It's high enough to change decisions in switch expansion which in turn can expose new jump threading opportunities. Skip the later tests on aarch64. */ /* { dg-final { scan-tree-dump-not "Jumps threaded" "dom3" { target { ! aarch64*-*-* } } } } */ -/* { dg-final { scan-tree-dump-not "Jumps threaded" "vrp2" { target { ! aarch64*-*-* } } } } */ +/* { dg-final { scan-tree-dump-not "Jumps threaded" "vrp-thread2" { target { ! aarch64*-*-* } } } } */ +/* { dg-final { scan-tree-dump "Jumps threaded: 11" "thread3" { target { ! aarch64*-*-* } } } } */ +/* { dg-final { scan-tree-dump "Jumps threaded: 18" "thread3" { target { aarch64*-*-* } } } } */ enum STATE { S0=0, diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-fre-97.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-fre-97.c new file mode 100644 index 0000000..2f09c8b --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/ssa-fre-97.c @@ -0,0 +1,19 @@ +/* { dg-do compile } */ +/* ethread threading does not yet catch this but it might at some point. */ +/* { dg-options "-O -fdump-tree-fre1-details -fno-thread-jumps" } */ + +int foo (int b, int x) +{ + int i, j; + if (b) + i = x; + if (b) + j = x; + return j == i; +} + +/* Even with different undefs we should CSE a PHI node with the + same controlling condition. */ + +/* { dg-final { scan-tree-dump "Replaced redundant PHI node" "fre1" } } */ +/* { dg-final { scan-tree-dump "return 1;" "fre1" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-thread-11.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-thread-11.c deleted file mode 100644 index 672a54e..0000000 --- a/gcc/testsuite/gcc.dg/tree-ssa/ssa-thread-11.c +++ /dev/null @@ -1,50 +0,0 @@ -/* { dg-do compile } */ -/* { dg-options "-O2 -fdump-tree-vrp2-details --param logical-op-non-short-circuit=1" } */ -/* { dg-additional-options "-fdisable-tree-ethread -fdisable-tree-thread1 -fdisable-tree-thread2" } */ -/* { dg-final { scan-tree-dump-not "IRREDUCIBLE_LOOP" "vrp2" } } */ - -void abort (void); -typedef struct bitmap_head_def *bitmap; -typedef const struct bitmap_head_def *const_bitmap; -typedef struct bitmap_obstack -{ - struct bitmap_obstack *next; - unsigned int indx; -} -bitmap_element; -typedef struct bitmap_head_def -{ - bitmap_element *first; -} -bitmap_head; -static __inline__ unsigned char -bitmap_elt_ior (bitmap dst, bitmap_element * dst_elt, - bitmap_element * dst_prev, const bitmap_element * a_elt, - const bitmap_element * b_elt) -{ - ((void) (!(a_elt || b_elt) ? abort (), 0 : 0)); -} - -unsigned char -bitmap_ior_and_compl (bitmap dst, const_bitmap a, const_bitmap b, - const_bitmap kill) -{ - bitmap_element *dst_elt = dst->first; - const bitmap_element *a_elt = a->first; - const bitmap_element *b_elt = b->first; - const bitmap_element *kill_elt = kill->first; - bitmap_element *dst_prev = ((void *) 0); - while (a_elt || b_elt) - { - if (b_elt && kill_elt && kill_elt->indx == b_elt->indx - && (!a_elt || a_elt->indx >= b_elt->indx)); - else - { - bitmap_elt_ior (dst, dst_elt, dst_prev, a_elt, b_elt); - if (a_elt && b_elt && a_elt->indx == b_elt->indx) - ; - else if (a_elt && (!b_elt || a_elt->indx <= b_elt->indx)) - a_elt = a_elt->next; - } - } -} diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-thread-12.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-thread-12.c deleted file mode 100644 index 08c0b8d..0000000 --- a/gcc/testsuite/gcc.dg/tree-ssa/ssa-thread-12.c +++ /dev/null @@ -1,73 +0,0 @@ -/* { dg-do compile } */ -/* { dg-options "-O2 -fdump-tree-thread3-details -fdump-tree-thread4-details -fno-finite-loops --param early-inlining-insns=14 -fno-inline-functions" } */ -/* { dg-final { scan-tree-dump "Registering jump thread" "thread3" } } */ -/* { dg-final { scan-tree-dump "Registering jump thread" "thread4" } } */ - -typedef struct bitmap_head_def *bitmap; -typedef const struct bitmap_head_def *const_bitmap; -typedef struct VEC_int_base -{ -} -VEC_int_base; -typedef struct VEC_int_heap -{ - VEC_int_base base; -} -VEC_int_heap; -typedef unsigned long BITMAP_WORD; -typedef struct bitmap_element_def -{ - struct bitmap_element_def *next; - unsigned int indx; -} -bitmap_element; -typedef struct bitmap_head_def -{ -} -bitmap_head; -typedef struct -{ - bitmap_element *elt1; - bitmap_element *elt2; - BITMAP_WORD bits; -} -bitmap_iterator; -static __inline__ void -bmp_iter_and_compl_init (bitmap_iterator * bi, const_bitmap map1, - const_bitmap map2, unsigned start_bit, - unsigned *bit_no) -{ -} - -static __inline__ void -bmp_iter_next (bitmap_iterator * bi, unsigned *bit_no) -{ -} - -static __inline__ unsigned char -bmp_iter_and_compl (bitmap_iterator * bi, unsigned *bit_no) -{ - if (bi->bits) - { - while (bi->elt2 && bi->elt2->indx < bi->elt1->indx) - bi->elt2 = bi->elt2->next; - } -} - -extern int VEC_int_base_length (VEC_int_base *); -bitmap -compute_idf (bitmap def_blocks, bitmap_head * dfs) -{ - bitmap_iterator bi; - unsigned bb_index, i; - VEC_int_heap *work_stack; - bitmap phi_insertion_points; - while ((VEC_int_base_length (((work_stack) ? &(work_stack)->base : 0))) > 0) - { - for (bmp_iter_and_compl_init - (&(bi), (&dfs[bb_index]), (phi_insertion_points), (0), &(i)); - bmp_iter_and_compl (&(bi), &(i)); bmp_iter_next (&(bi), &(i))) - { - } - } -} diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-thread-backedge.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-thread-backedge.c new file mode 100644 index 0000000..890a0ee --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/ssa-thread-backedge.c @@ -0,0 +1,32 @@ +// { dg-do compile } +// { dg-options "-O2 -fdisable-tree-ethread -fdisable-tree-thread1 -fdisable-tree-thread2 -fno-tree-dominator-opts -fdump-tree-thread3-details" } + +// Test that we can thread jumps across the backedge of a loop through +// the switch statement to a particular case. +// +// Just in case, we disable all the jump threaders before loop +// optimizations to make sure we get a clean stab at this. + +int foo (unsigned int x, int s) +{ + while (s != 999) + { + switch (s) + { + case 0: + if (x) + s = 1; + break; + case 1: + if (x) + s = 999; + break; + default: + break; + } + x++; + } + return s; +} + +// { dg-final { scan-tree-dump "Registering jump thread:.*normal \\(back\\)" "thread3" } } diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-thread-invalid.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-thread-invalid.c new file mode 100644 index 0000000..bd56a62 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/ssa-thread-invalid.c @@ -0,0 +1,102 @@ +// { dg-do compile } +// { dg-options "-O2 -fgimple -fdump-statistics" } +// +// This is a collection of seemingly threadble paths that should not be allowed. + +void foobar (int); + +// Possible thread from 2->4->3, but it would rotate the loop. +void __GIMPLE (ssa) +f1 () +{ + int i; + + // Pre-header. + __BB(2): + goto __BB4; + + // Latch. + __BB(3): + foobar (i_1); + i_5 = i_1 + 1; + goto __BB4; + + __BB(4,loop_header(1)): + i_1 = __PHI (__BB2: 0, __BB3: i_5); + if (i_1 != 101) + goto __BB3; + else + goto __BB5; + + __BB(5): + return; + +} + +// Possible thread from 2->3->5 but threading through the empty latch +// would create a non-empty latch. +void __GIMPLE (ssa) +f2 () +{ + int i; + + // Pre-header. + __BB(2): + goto __BB3; + + __BB(3,loop_header(1)): + i_8 = __PHI (__BB5: i_5, __BB2: 0); + foobar (i_8); + i_5 = i_8 + 1; + if (i_5 != 256) + goto __BB5; + else + goto __BB4; + + // Latch. + __BB(5): + goto __BB3; + + __BB(4): + return; + +} + +// Possible thread from 3->5->6->3 but this would thread through the +// header but not exit the loop. +int __GIMPLE (ssa) +f3 (int a) +{ + int i; + + __BB(2): + goto __BB6; + + __BB(3): + if (i_1 != 0) + goto __BB4; + else + goto __BB5; + + __BB(4): + foobar (5); + goto __BB5; + + // Latch. + __BB(5): + i_7 = i_1 + 1; + goto __BB6; + + __BB(6,loop_header(1)): + i_1 = __PHI (__BB2: 1, __BB5: i_7); + if (i_1 <= 99) + goto __BB3; + else + goto __BB7; + + __BB(7): + return; + +} + +// { dg-final { scan-tree-dump-not "Jumps threaded" "statistics" } } diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-vrp-thread-1.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-vrp-thread-1.c index 86d07ef..f3ca140 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/ssa-vrp-thread-1.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/ssa-vrp-thread-1.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-O2 -fdump-tree-vrp-thread1-details -fdelete-null-pointer-checks" } */ +/* { dg-options "-O2 -fdump-tree-thread1-details -fdelete-null-pointer-checks" } */ /* { dg-skip-if "" keeps_null_pointer_checks } */ void oof (void); @@ -29,5 +29,5 @@ build_omp_regions_1 (basic_block bb, struct omp_region *parent, /* ARM Cortex-M defined LOGICAL_OP_NON_SHORT_CIRCUIT to false, so skip below test. */ -/* { dg-final { scan-tree-dump-times "Threaded" 1 "vrp-thread1" { target { ! arm_cortex_m } } } } */ +/* { dg-final { scan-tree-dump-times "Registering jump thread" 1 "thread1" { target { ! arm_cortex_m } } } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/vrp08.c b/gcc/testsuite/gcc.dg/tree-ssa/vrp08.c index c2da30b..2c6742b 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/vrp08.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/vrp08.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-O2 -fno-tree-fre -fdisable-tree-evrp -fdump-tree-vrp1-details -fdelete-null-pointer-checks" } */ +/* { dg-options "-O2 -fno-tree-fre -fdisable-tree-evrp -fdump-tree-vrp1-details -fdisable-tree-thread1 -fdelete-null-pointer-checks" } */ /* Compile with -fno-tree-fre -O2 to prevent CSEing *p. */ int diff --git a/gcc/testsuite/gcc.dg/tree-ssa/vrp55.c b/gcc/testsuite/gcc.dg/tree-ssa/vrp55.c index a478a69..0ef57d9 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/vrp55.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/vrp55.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-O2 -fdump-tree-vrp-thread1-blocks-vops-details -fdelete-null-pointer-checks" } */ +/* { dg-options "-O2 -fdump-tree-ethread-details -fdelete-null-pointer-checks" } */ void arf (void); @@ -12,6 +12,6 @@ fu (char *p, int x) arf (); } -/* { dg-final { scan-tree-dump-times "Threaded jump" 1 "vrp-thread1" { target { ! keeps_null_pointer_checks } } } } */ -/* { dg-final { scan-tree-dump-times "Threaded jump" 0 "vrp-thread1" { target { keeps_null_pointer_checks } } } } */ +/* { dg-final { scan-tree-dump-times "Registering jump thread" 1 "ethread" { target { ! keeps_null_pointer_checks } } } } */ +/* { dg-final { scan-tree-dump-times "Registering jump thread" 0 "ethread" { target { keeps_null_pointer_checks } } } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/vrp98-1.c b/gcc/testsuite/gcc.dg/tree-ssa/vrp98-1.c new file mode 100644 index 0000000..daa3f07 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/vrp98-1.c @@ -0,0 +1,41 @@ +/* { dg-do compile } */ +/* { dg-require-effective-target int128 } */ +/* { dg-options "-Os -fdump-tree-evrp-details" } */ + +#include <stdint.h> +#include <limits.h> + +typedef unsigned int word __attribute__((mode(word))); +typedef unsigned __int128 bigger_than_word; + +int +foo (bigger_than_word a, word b, uint8_t c) +{ + /* Must fold use of t1 into use of b, as b is no wider than word_mode. */ + const uint8_t t1 = b % UCHAR_MAX; + + /* Must NOT fold use of t2 into use of a, as a is wider than word_mode. */ + const uint8_t t2 = a % UCHAR_MAX; + + /* Must fold use of t3 into use of c, as c is narrower than t3. */ + const uint32_t t3 = (const uint32_t)(c >> 1); + + uint16_t ret = 0; + + if (t1 == 1) + ret = 20; + else if (t2 == 2) + ret = 30; + else if (t3 == 3) + ret = 40; + /* Th extra condition below is necessary to prevent a prior pass from + folding away the cast. Ignored in scan-tree-dump. */ + else if (t3 == 4) + ret = 50; + + return ret; +} + +/* { dg-final { scan-tree-dump "Folded into: if \\(_\[0-9\]+ == 1\\)" "evrp" } } */ +/* { dg-final { scan-tree-dump-not "Folded into: if \\(_\[0-9\]+ == 2\\)" "evrp" } } */ +/* { dg-final { scan-tree-dump "Folded into: if \\(_\[0-9\]+ == 3\\)" "evrp" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/vrp98.c b/gcc/testsuite/gcc.dg/tree-ssa/vrp98.c index 982f091..78d3bba 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/vrp98.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/vrp98.c @@ -1,6 +1,6 @@ /* { dg-do compile } */ /* { dg-require-effective-target int128 } */ -/* { dg-options "-Os -fdump-tree-vrp1-details" } */ +/* { dg-options "-Os -fdisable-tree-evrp -fdump-tree-vrp1-details" } */ #include <stdint.h> #include <limits.h> diff --git a/gcc/testsuite/gcc.dg/ubsan/pr81981.c b/gcc/testsuite/gcc.dg/ubsan/pr81981.c index 8a6597c..d201efb 100644 --- a/gcc/testsuite/gcc.dg/ubsan/pr81981.c +++ b/gcc/testsuite/gcc.dg/ubsan/pr81981.c @@ -16,6 +16,6 @@ foo (int i) u[0] = i; } - v = u[0]; /* { dg-warning "may be used uninitialized" } */ + v = u[0]; /* { dg-warning "may be used uninitialized" "" { xfail *-*-* } } */ return t[0]; /* { dg-warning "may be used uninitialized" } */ } diff --git a/gcc/testsuite/gcc.dg/uninit-pr89230-1.c b/gcc/testsuite/gcc.dg/uninit-pr89230-1.c index 1c07c4f..dfc87a5 100644 --- a/gcc/testsuite/gcc.dg/uninit-pr89230-1.c +++ b/gcc/testsuite/gcc.dg/uninit-pr89230-1.c @@ -8,7 +8,8 @@ struct S { int i, j; }; int g (void) { - struct S *p = f (), *q; + struct S *p = f (); + struct S *q; // { dg-bogus "may be used uninitialized" "uninitialized" { xfail *-*-* } } if (p->i || !(q = f ()) || p->j != q->i) { diff --git a/gcc/testsuite/gcc.dg/vect/bb-slp-16.c b/gcc/testsuite/gcc.dg/vect/bb-slp-16.c index e68a9b6..82fae06 100644 --- a/gcc/testsuite/gcc.dg/vect/bb-slp-16.c +++ b/gcc/testsuite/gcc.dg/vect/bb-slp-16.c @@ -1,4 +1,6 @@ /* { dg-require-effective-target vect_int } */ +/* The SLP vectorization happens as part of the if-converted loop body. */ +/* { dg-additional-options "-fdump-tree-vect-details" } */ #include <stdarg.h> #include "tree-vect.h" @@ -65,5 +67,4 @@ int main (void) return 0; } -/* { dg-final { scan-tree-dump-times "optimized: basic block" 1 "slp1" } } */ - +/* { dg-final { scan-tree-dump-times "optimized: basic block" 1 "vect" } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/fmla_intrinsic_1.c b/gcc/testsuite/gcc.target/aarch64/fmla_intrinsic_1.c index 59ad41e..adb787a 100644 --- a/gcc/testsuite/gcc.target/aarch64/fmla_intrinsic_1.c +++ b/gcc/testsuite/gcc.target/aarch64/fmla_intrinsic_1.c @@ -11,6 +11,7 @@ extern void abort (void); #define TEST_VMLA(q1, q2, size, in1_lanes, in2_lanes) \ static void \ +__attribute__((noipa,noinline)) \ test_vfma##q1##_lane##q2##_f##size (float##size##_t * res, \ const float##size##_t *in1, \ const float##size##_t *in2) \ @@ -104,12 +105,12 @@ main (int argc, char **argv) vfmaq_laneq_f32. */ /* { dg-final { scan-assembler-times "fmla\\tv\[0-9\]+\.4s, v\[0-9\]+\.4s, v\[0-9\]+\.s\\\[\[0-9\]+\\\]" 2 } } */ -/* vfma_lane_f64. */ -/* { dg-final { scan-assembler-times "fmadd\\td\[0-9\]+\, d\[0-9\]+\, d\[0-9\]+\, d\[0-9\]+" 1 } } */ +/* vfma_lane_f64. + vfma_laneq_f64. */ +/* { dg-final { scan-assembler-times "fmadd\\td\[0-9\]+\, d\[0-9\]+\, d\[0-9\]+\, d\[0-9\]+" 2 } } */ /* vfmaq_lane_f64. - vfma_laneq_f64. vfmaq_laneq_f64. */ -/* { dg-final { scan-assembler-times "fmla\\tv\[0-9\]+\.2d, v\[0-9\]+\.2d, v\[0-9\]+\.d\\\[\[0-9\]+\\\]" 3 } } */ +/* { dg-final { scan-assembler-times "fmla\\tv\[0-9\]+\.2d, v\[0-9\]+\.2d, v\[0-9\]+\.d\\\[\[0-9\]+\\\]" 2 } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/fmls_intrinsic_1.c b/gcc/testsuite/gcc.target/aarch64/fmls_intrinsic_1.c index 2d5a3d3..865def2 100644 --- a/gcc/testsuite/gcc.target/aarch64/fmls_intrinsic_1.c +++ b/gcc/testsuite/gcc.target/aarch64/fmls_intrinsic_1.c @@ -11,6 +11,7 @@ extern void abort (void); #define TEST_VMLS(q1, q2, size, in1_lanes, in2_lanes) \ static void \ +__attribute__((noipa,noinline)) \ test_vfms##q1##_lane##q2##_f##size (float##size##_t * res, \ const float##size##_t *in1, \ const float##size##_t *in2) \ @@ -105,12 +106,12 @@ main (int argc, char **argv) vfmsq_laneq_f32. */ /* { dg-final { scan-assembler-times "fmls\\tv\[0-9\]+\.4s, v\[0-9\]+\.4s, v\[0-9\]+\.s\\\[\[0-9\]+\\\]" 2 } } */ -/* vfms_lane_f64. */ -/* { dg-final { scan-assembler-times "fmsub\\td\[0-9\]+\, d\[0-9\]+\, d\[0-9\]+\, d\[0-9\]+" 1 } } */ +/* vfms_lane_f64. + vfms_laneq_f64. */ +/* { dg-final { scan-assembler-times "fmsub\\td\[0-9\]+\, d\[0-9\]+\, d\[0-9\]+\, d\[0-9\]+" 2 } } */ /* vfmsq_lane_f64. - vfms_laneq_f64. vfmsq_laneq_f64. */ -/* { dg-final { scan-assembler-times "fmls\\tv\[0-9\]+\.2d, v\[0-9\]+\.2d, v\[0-9\]+\.d\\\[\[0-9\]+\\\]" 3 } } */ +/* { dg-final { scan-assembler-times "fmls\\tv\[0-9\]+\.2d, v\[0-9\]+\.2d, v\[0-9\]+\.d\\\[\[0-9\]+\\\]" 2 } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/fmul_intrinsic_1.c b/gcc/testsuite/gcc.target/aarch64/fmul_intrinsic_1.c index 8b0880d..d01095e 100644 --- a/gcc/testsuite/gcc.target/aarch64/fmul_intrinsic_1.c +++ b/gcc/testsuite/gcc.target/aarch64/fmul_intrinsic_1.c @@ -9,6 +9,7 @@ extern double fabs (double); #define TEST_VMUL(q1, q2, size, in1_lanes, in2_lanes) \ static void \ +__attribute__((noipa,noinline)) \ test_vmul##q1##_lane##q2##_f##size (float##size##_t * res, \ const float##size##_t *in1, \ const float##size##_t *in2) \ @@ -104,12 +105,12 @@ main (int argc, char **argv) vmulq_laneq_f32. */ /* { dg-final { scan-assembler-times "fmul\\tv\[0-9\]+\.4s, v\[0-9\]+\.4s, v\[0-9\]+\.s\\\[\[0-9\]+\\\]" 2 } } */ -/* vmul_lane_f64. */ -/* { dg-final { scan-assembler-times "fmul\\td\[0-9\]+, d\[0-9\]+, d\[0-9\]+" 1 } } */ +/* vmul_lane_f64. + Vmul_laneq_f64. */ +/* { dg-final { scan-assembler-times "fmul\\td\[0-9\]+, d\[0-9\]+, d\[0-9\]+" 2 } } */ -/* vmul_laneq_f64. - vmulq_lane_f64. +/* vmulq_lane_f64. vmulq_laneq_f64. */ -/* { dg-final { scan-assembler-times "fmul\\tv\[0-9\]+\.2d, v\[0-9\]+\.2d, v\[0-9\]+\.d\\\[\[0-9\]+\\\]" 3 } } */ +/* { dg-final { scan-assembler-times "fmul\\tv\[0-9\]+\.2d, v\[0-9\]+\.2d, v\[0-9\]+\.d\\\[\[0-9\]+\\\]" 2 } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/frint.x b/gcc/testsuite/gcc.target/aarch64/frint.x index 1403740..d598a25 100644 --- a/gcc/testsuite/gcc.target/aarch64/frint.x +++ b/gcc/testsuite/gcc.target/aarch64/frint.x @@ -4,6 +4,7 @@ extern GPF SUFFIX(floor) (GPF); extern GPF SUFFIX(nearbyint) (GPF); extern GPF SUFFIX(rint) (GPF); extern GPF SUFFIX(round) (GPF); +extern GPF SUFFIX(roundeven) (GPF); GPF test1a (GPF x) { @@ -64,3 +65,14 @@ GPF test6b (GPF x) { return SUFFIX(round)(x); } + +GPF test7a (GPF x) +{ + return SUFFIX(__builtin_roundeven)(x); +} + +GPF test7b (GPF x) +{ + return SUFFIX(roundeven)(x); +} + diff --git a/gcc/testsuite/gcc.target/aarch64/frint_double.c b/gcc/testsuite/gcc.target/aarch64/frint_double.c index 9613949..1d28eb0 100644 --- a/gcc/testsuite/gcc.target/aarch64/frint_double.c +++ b/gcc/testsuite/gcc.target/aarch64/frint_double.c @@ -12,3 +12,4 @@ /* { dg-final { scan-assembler-times "frinti\td\[0-9\]" 2 } } */ /* { dg-final { scan-assembler-times "frintx\td\[0-9\]" 2 } } */ /* { dg-final { scan-assembler-times "frinta\td\[0-9\]" 2 } } */ +/* { dg-final { scan-assembler-times "frintn\td\[0-9\]" 2 } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/frint_float.c b/gcc/testsuite/gcc.target/aarch64/frint_float.c index 493ec37..530cf97 100644 --- a/gcc/testsuite/gcc.target/aarch64/frint_float.c +++ b/gcc/testsuite/gcc.target/aarch64/frint_float.c @@ -12,3 +12,4 @@ /* { dg-final { scan-assembler-times "frinti\ts\[0-9\]" 2 } } */ /* { dg-final { scan-assembler-times "frintx\ts\[0-9\]" 2 } } */ /* { dg-final { scan-assembler-times "frinta\ts\[0-9\]" 2 } } */ +/* { dg-final { scan-assembler-times "frintn\ts\[0-9\]" 2 } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/merge_trunc1.c b/gcc/testsuite/gcc.target/aarch64/merge_trunc1.c new file mode 100644 index 0000000..0721706 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/merge_trunc1.c @@ -0,0 +1,41 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -ffast-math" } */ + +float +f1 (float x) +{ + int y = x; + + return (float) y; +} + +double +f2 (double x) +{ + long y = x; + + return (double) y; +} + +float +f3 (double x) +{ + int y = x; + + return (float) y; +} + +double +f4 (float x) +{ + int y = x; + + return (double) y; +} + +/* { dg-final { scan-assembler "frintz\\ts\[0-9\]+, s\[0-9\]+" } } */ +/* { dg-final { scan-assembler "frintz\\td\[0-9\]+, d\[0-9\]+" } } */ +/* { dg-final { scan-assembler "fcvtzs\\tw\[0-9\]+, d\[0-9\]+" } } */ +/* { dg-final { scan-assembler "scvtf\\ts\[0-9\]+, w\[0-9\]+" } } */ +/* { dg-final { scan-assembler "fcvtzs\\tw\[0-9\]+, s\[0-9\]+" } } */ +/* { dg-final { scan-assembler "scvtf\\td\[0-9\]+, w\[0-9\]+" } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/mla_intrinsic_1.c b/gcc/testsuite/gcc.target/aarch64/mla_intrinsic_1.c index 46b3c78..885bfb3 100644 --- a/gcc/testsuite/gcc.target/aarch64/mla_intrinsic_1.c +++ b/gcc/testsuite/gcc.target/aarch64/mla_intrinsic_1.c @@ -11,6 +11,7 @@ extern void abort (void); #define TEST_VMLA(q, su, size, in1_lanes, in2_lanes) \ static void \ +__attribute__((noipa,noinline)) \ test_vmlaq_lane##q##_##su##size (MAP##su (size, ) * res, \ const MAP##su(size, ) *in1, \ const MAP##su(size, ) *in2) \ diff --git a/gcc/testsuite/gcc.target/aarch64/mls_intrinsic_1.c b/gcc/testsuite/gcc.target/aarch64/mls_intrinsic_1.c index e01a4f6..df046ce 100644 --- a/gcc/testsuite/gcc.target/aarch64/mls_intrinsic_1.c +++ b/gcc/testsuite/gcc.target/aarch64/mls_intrinsic_1.c @@ -11,6 +11,7 @@ extern void abort (void); #define TEST_VMLS(q, su, size, in1_lanes, in2_lanes) \ static void \ +__attribute__((noipa,noinline)) \ test_vmlsq_lane##q##_##su##size (MAP##su (size, ) * res, \ const MAP##su(size, ) *in1, \ const MAP##su(size, ) *in2) \ diff --git a/gcc/testsuite/gcc.target/aarch64/mul_intrinsic_1.c b/gcc/testsuite/gcc.target/aarch64/mul_intrinsic_1.c index 00ef4f2..517b937 100644 --- a/gcc/testsuite/gcc.target/aarch64/mul_intrinsic_1.c +++ b/gcc/testsuite/gcc.target/aarch64/mul_intrinsic_1.c @@ -11,6 +11,7 @@ extern void abort (void); #define TEST_VMUL(q, su, size, in1_lanes, in2_lanes) \ static void \ +__attribute__((noipa,noinline)) \ test_vmulq_lane##q##_##su##size (MAP##su (size, ) * res, \ const MAP##su(size, ) *in1, \ const MAP##su(size, ) *in2) \ diff --git a/gcc/testsuite/gcc.target/aarch64/mvn-cmeq0-1.c b/gcc/testsuite/gcc.target/aarch64/mvn-cmeq0-1.c new file mode 100644 index 0000000..27b3909 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/mvn-cmeq0-1.c @@ -0,0 +1,17 @@ +/* { dg-do assemble } */ +/* { dg-options "-O --save-temps" } */ + +#include <arm_neon.h> + +uint8x8_t bar(int16x8_t abs_row0, int16x8_t row0) { + uint16x8_t row0_diff = + vreinterpretq_u16_s16(veorq_s16(abs_row0, vshrq_n_s16(row0, 15))); + uint8x8_t abs_row0_gt0 = + vmovn_u16(vcgtq_u16(vreinterpretq_u16_s16(abs_row0), vdupq_n_u16(0))); + return abs_row0_gt0; +} + + +/* { dg-final { scan-assembler-times {\tcmtst\t} 1 } } */ +/* { dg-final { scan-assembler-not {\tcmeq\t} } } */ +/* { dg-final { scan-assembler-not {\tnot\t} } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/narrow_high_combine.c b/gcc/testsuite/gcc.target/aarch64/narrow_high_combine.c index 50ecab0..fa61196 100644 --- a/gcc/testsuite/gcc.target/aarch64/narrow_high_combine.c +++ b/gcc/testsuite/gcc.target/aarch64/narrow_high_combine.c @@ -225,7 +225,8 @@ TEST_2_UNARY (vqmovun, uint32x4_t, int64x2_t, s64, u32) /* { dg-final { scan-assembler-times "\\tuqshrn2\\tv" 6} } */ /* { dg-final { scan-assembler-times "\\tsqrshrn2\\tv" 6} } */ /* { dg-final { scan-assembler-times "\\tuqrshrn2\\tv" 6} } */ -/* { dg-final { scan-assembler-times "\\txtn2\\tv" 12} } */ +/* { dg-final { scan-assembler-times "\\txtn2\\tv" 6} } */ +/* { dg-final { scan-assembler-times "\\tuzp1\\tv" 6} } */ /* { dg-final { scan-assembler-times "\\tuqxtn2\\tv" 6} } */ /* { dg-final { scan-assembler-times "\\tsqxtn2\\tv" 6} } */ /* { dg-final { scan-assembler-times "\\tsqxtun2\\tv" 6} } */ diff --git a/gcc/testsuite/gcc.target/aarch64/shl-combine-2.c b/gcc/testsuite/gcc.target/aarch64/shl-combine-2.c new file mode 100644 index 0000000..6a0331f --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/shl-combine-2.c @@ -0,0 +1,14 @@ +/* { dg-do assemble } */ +/* { dg-options "-O3 --save-temps --param=vect-epilogues-nomask=0" } */ + +#define TYPE char + +void e (signed TYPE * restrict a, signed TYPE *b, int n) +{ + for (int i = 0; i < n; i++) + b[i] = a[i] >> (sizeof(TYPE)*8)-1; +} + +/* { dg-final { scan-assembler-times {\tcmlt\t} 1 } } */ +/* { dg-final { scan-assembler-not {\tsshr\t} } } */ + diff --git a/gcc/testsuite/gcc.target/aarch64/shl-combine-3.c b/gcc/testsuite/gcc.target/aarch64/shl-combine-3.c new file mode 100644 index 0000000..2086b24a --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/shl-combine-3.c @@ -0,0 +1,14 @@ +/* { dg-do assemble } */ +/* { dg-options "-O3 --save-temps --param=vect-epilogues-nomask=0" } */ + +#define TYPE short + +void e (signed TYPE * restrict a, signed TYPE *b, int n) +{ + for (int i = 0; i < n; i++) + b[i] = a[i] >> (sizeof(TYPE)*8)-1; +} + +/* { dg-final { scan-assembler-times {\tcmlt\t} 1 } } */ +/* { dg-final { scan-assembler-not {\tsshr\t} } } */ + diff --git a/gcc/testsuite/gcc.target/aarch64/shl-combine-4.c b/gcc/testsuite/gcc.target/aarch64/shl-combine-4.c new file mode 100644 index 0000000..0831810 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/shl-combine-4.c @@ -0,0 +1,14 @@ +/* { dg-do assemble } */ +/* { dg-options "-O3 --save-temps --param=vect-epilogues-nomask=0" } */ + +#define TYPE int + +void e (signed TYPE * restrict a, signed TYPE *b, int n) +{ + for (int i = 0; i < n; i++) + b[i] = a[i] >> (sizeof(TYPE)*8)-1; +} + +/* { dg-final { scan-assembler-times {\tcmlt\t} 1 } } */ +/* { dg-final { scan-assembler-not {\tsshr\t} } } */ + diff --git a/gcc/testsuite/gcc.target/aarch64/shl-combine-5.c b/gcc/testsuite/gcc.target/aarch64/shl-combine-5.c new file mode 100644 index 0000000..6b2a6bd --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/shl-combine-5.c @@ -0,0 +1,14 @@ +/* { dg-do assemble } */ +/* { dg-options "-O3 --save-temps --param=vect-epilogues-nomask=0" } */ + +#define TYPE long + +void e (signed TYPE * restrict a, signed TYPE *b, int n) +{ + for (int i = 0; i < n; i++) + b[i] = a[i] >> (sizeof(TYPE)*8)-1; +} + +/* { dg-final { scan-assembler-times {\tcmlt\t} 1 } } */ +/* { dg-final { scan-assembler-not {\tsshr\t} } } */ + diff --git a/gcc/testsuite/gcc.target/aarch64/shrn-combine-1.c b/gcc/testsuite/gcc.target/aarch64/shrn-combine-1.c new file mode 100644 index 0000000..334e94a --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/shrn-combine-1.c @@ -0,0 +1,15 @@ +/* { dg-do assemble } */ +/* { dg-options "-O3 --save-temps --param=vect-epilogues-nomask=0" } */ + +#pragma GCC target "+nosve" + +#define TYPE char + +void foo (unsigned TYPE * restrict a, TYPE * restrict d, int n) +{ + for( int i = 0; i < n; i++ ) + d[i] = (a[i] * a[i]) >> 2; +} + +/* { dg-final { scan-assembler-times {\tshrn\t} 1 } } */ +/* { dg-final { scan-assembler-times {\tshrn2\t} 1 } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/shrn-combine-10.c b/gcc/testsuite/gcc.target/aarch64/shrn-combine-10.c new file mode 100644 index 0000000..3a1cfce --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/shrn-combine-10.c @@ -0,0 +1,14 @@ +/* { dg-do assemble } */ +/* { dg-options "-O3 --save-temps --param=vect-epilogues-nomask=0" } */ + + +#include <arm_neon.h> + +uint32x4_t foo (uint64x2_t a, uint64x2_t b) +{ + return vrshrn_high_n_u64 (vrshrn_n_u64 (a, 32), b, 32); +} + +/* { dg-final { scan-assembler-times {\tuzp2\t} 1 } } */ +/* { dg-final { scan-assembler-not {\tshrn\t} } } */ +/* { dg-final { scan-assembler-not {\tshrn2\t} } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/shrn-combine-2.c b/gcc/testsuite/gcc.target/aarch64/shrn-combine-2.c new file mode 100644 index 0000000..c90de72 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/shrn-combine-2.c @@ -0,0 +1,15 @@ +/* { dg-do assemble } */ +/* { dg-options "-O3 --save-temps --param=vect-epilogues-nomask=0" } */ + +#pragma GCC target "+nosve" + +#define TYPE short + +void foo (unsigned TYPE * restrict a, TYPE * restrict d, int n) +{ + for( int i = 0; i < n; i++ ) + d[i] = (a[i] * a[i]) >> 2; +} + +/* { dg-final { scan-assembler-times {\tshrn\t} 1 } } */ +/* { dg-final { scan-assembler-times {\tshrn2\t} 1 } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/shrn-combine-3.c b/gcc/testsuite/gcc.target/aarch64/shrn-combine-3.c new file mode 100644 index 0000000..a05ecbb --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/shrn-combine-3.c @@ -0,0 +1,15 @@ +/* { dg-do assemble } */ +/* { dg-options "-O3 --save-temps --param=vect-epilogues-nomask=0" } */ + +#pragma GCC target "+nosve" + +#define TYPE int + +void foo (unsigned long long * restrict a, TYPE * restrict d, int n) +{ + for( int i = 0; i < n; i++ ) + d[i] = a[i] >> 3; +} + +/* { dg-final { scan-assembler-times {\tshrn\t} 1 } } */ +/* { dg-final { scan-assembler-times {\tshrn2\t} 1 } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/shrn-combine-4.c b/gcc/testsuite/gcc.target/aarch64/shrn-combine-4.c new file mode 100644 index 0000000..36ebab7 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/shrn-combine-4.c @@ -0,0 +1,15 @@ +/* { dg-do assemble } */ +/* { dg-options "-O3 --save-temps --param=vect-epilogues-nomask=0" } */ + +#pragma GCC target "+nosve" + +#define TYPE long long + +void foo (unsigned TYPE * restrict a, TYPE * restrict d, int n) +{ + for( int i = 0; i < n; i++ ) + d[i] = (a[i] * a[i]) >> 2; +} + +/* { dg-final { scan-assembler-not {\tshrn\t} } } */ +/* { dg-final { scan-assembler-not {\tshrn2\t} } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/shrn-combine-5.c b/gcc/testsuite/gcc.target/aarch64/shrn-combine-5.c new file mode 100644 index 0000000..973e577 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/shrn-combine-5.c @@ -0,0 +1,18 @@ +/* { dg-do assemble } */ +/* { dg-options "-O3 --save-temps --param=vect-epilogues-nomask=0" } */ + +#pragma GCC target "+nosve" + +#define TYPE1 char +#define TYPE2 short +#define SHIFT 8 + +void foo (TYPE2 * restrict a, TYPE1 * restrict d, int n) +{ + for( int i = 0; i < n; i++ ) + d[i] = a[i] >> SHIFT; +} + +/* { dg-final { scan-assembler-times {\tuzp2\t} 1 } } */ +/* { dg-final { scan-assembler-not {\tshrn\t} } } */ +/* { dg-final { scan-assembler-not {\tshrn2\t} } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/shrn-combine-6.c b/gcc/testsuite/gcc.target/aarch64/shrn-combine-6.c new file mode 100644 index 0000000..db36a9c --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/shrn-combine-6.c @@ -0,0 +1,18 @@ +/* { dg-do assemble } */ +/* { dg-options "-O3 --save-temps --param=vect-epilogues-nomask=0" } */ + +#pragma GCC target "+nosve" + +#define TYPE1 short +#define TYPE2 int +#define SHIFT 16 + +void foo (TYPE2 * restrict a, TYPE1 * restrict d, int n) +{ + for( int i = 0; i < n; i++ ) + d[i] = a[i] >> SHIFT; +} + +/* { dg-final { scan-assembler-times {\tuzp2\t} 1 } } */ +/* { dg-final { scan-assembler-not {\tshrn\t} } } */ +/* { dg-final { scan-assembler-not {\tshrn2\t} } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/shrn-combine-7.c b/gcc/testsuite/gcc.target/aarch64/shrn-combine-7.c new file mode 100644 index 0000000..e7caf3c --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/shrn-combine-7.c @@ -0,0 +1,18 @@ +/* { dg-do assemble } */ +/* { dg-options "-O3 --save-temps --param=vect-epilogues-nomask=0" } */ + +#pragma GCC target "+nosve" + +#define TYPE1 int +#define TYPE2 long long +#define SHIFT 32 + +void foo (TYPE2 * restrict a, TYPE1 * restrict d, int n) +{ + for( int i = 0; i < n; i++ ) + d[i] = a[i] >> SHIFT; +} + +/* { dg-final { scan-assembler-times {\tuzp2\t} 1 } } */ +/* { dg-final { scan-assembler-not {\tshrn\t} } } */ +/* { dg-final { scan-assembler-not {\tshrn2\t} } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/shrn-combine-8.c b/gcc/testsuite/gcc.target/aarch64/shrn-combine-8.c new file mode 100644 index 0000000..6a47f3c --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/shrn-combine-8.c @@ -0,0 +1,14 @@ +/* { dg-do assemble } */ +/* { dg-options "-O3 --save-temps --param=vect-epilogues-nomask=0" } */ + + +#include <arm_neon.h> + +uint8x16_t foo (uint16x8_t a, uint16x8_t b) +{ + return vrshrn_high_n_u16 (vrshrn_n_u16 (a, 8), b, 8); +} + +/* { dg-final { scan-assembler-times {\tuzp2\t} 1 } } */ +/* { dg-final { scan-assembler-not {\tshrn\t} } } */ +/* { dg-final { scan-assembler-not {\tshrn2\t} } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/shrn-combine-9.c b/gcc/testsuite/gcc.target/aarch64/shrn-combine-9.c new file mode 100644 index 0000000..929a55c --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/shrn-combine-9.c @@ -0,0 +1,14 @@ +/* { dg-do assemble } */ +/* { dg-options "-O3 --save-temps --param=vect-epilogues-nomask=0" } */ + + +#include <arm_neon.h> + +uint16x8_t foo (uint32x4_t a, uint32x4_t b) +{ + return vrshrn_high_n_u32 (vrshrn_n_u32 (a, 16), b, 16); +} + +/* { dg-final { scan-assembler-times {\tuzp2\t} 1 } } */ +/* { dg-final { scan-assembler-not {\tshrn\t} } } */ +/* { dg-final { scan-assembler-not {\tshrn2\t} } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/simd/vmul_elem_1.c b/gcc/testsuite/gcc.target/aarch64/simd/vmul_elem_1.c index a1faefd..ffa391a 100644 --- a/gcc/testsuite/gcc.target/aarch64/simd/vmul_elem_1.c +++ b/gcc/testsuite/gcc.target/aarch64/simd/vmul_elem_1.c @@ -146,12 +146,14 @@ check_v2sf (float32_t elemA, float32_t elemB) vst1_f32 (vec32x2_res, vmul_n_f32 (vec32x2_src, elemA)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 2; indx++) if (* (uint32_t *) &vec32x2_res[indx] != * (uint32_t *) &expected2_1[indx]) abort (); vst1_f32 (vec32x2_res, vmul_n_f32 (vec32x2_src, elemB)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 2; indx++) if (* (uint32_t *) &vec32x2_res[indx] != * (uint32_t *) &expected2_2[indx]) abort (); @@ -169,24 +171,28 @@ check_v4sf (float32_t elemA, float32_t elemB, float32_t elemC, float32_t elemD) vst1q_f32 (vec32x4_res, vmulq_n_f32 (vec32x4_src, elemA)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 4; indx++) if (* (uint32_t *) &vec32x4_res[indx] != * (uint32_t *) &expected4_1[indx]) abort (); vst1q_f32 (vec32x4_res, vmulq_n_f32 (vec32x4_src, elemB)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 4; indx++) if (* (uint32_t *) &vec32x4_res[indx] != * (uint32_t *) &expected4_2[indx]) abort (); vst1q_f32 (vec32x4_res, vmulq_n_f32 (vec32x4_src, elemC)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 4; indx++) if (* (uint32_t *) &vec32x4_res[indx] != * (uint32_t *) &expected4_3[indx]) abort (); vst1q_f32 (vec32x4_res, vmulq_n_f32 (vec32x4_src, elemD)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 4; indx++) if (* (uint32_t *) &vec32x4_res[indx] != * (uint32_t *) &expected4_4[indx]) abort (); @@ -204,12 +210,14 @@ check_v2df (float64_t elemdC, float64_t elemdD) vst1q_f64 (vec64x2_res, vmulq_n_f64 (vec64x2_src, elemdC)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 2; indx++) if (* (uint64_t *) &vec64x2_res[indx] != * (uint64_t *) &expectedd2_1[indx]) abort (); vst1q_f64 (vec64x2_res, vmulq_n_f64 (vec64x2_src, elemdD)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 2; indx++) if (* (uint64_t *) &vec64x2_res[indx] != * (uint64_t *) &expectedd2_2[indx]) abort (); @@ -227,12 +235,14 @@ check_v2si (int32_t elemsA, int32_t elemsB) vst1_s32 (vecs32x2_res, vmul_n_s32 (vecs32x2_src, elemsA)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 2; indx++) if (vecs32x2_res[indx] != expecteds2_1[indx]) abort (); vst1_s32 (vecs32x2_res, vmul_n_s32 (vecs32x2_src, elemsB)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 2; indx++) if (vecs32x2_res[indx] != expecteds2_2[indx]) abort (); @@ -248,12 +258,14 @@ check_v2si_unsigned (uint32_t elemusA, uint32_t elemusB) vst1_u32 (vecus32x2_res, vmul_n_u32 (vecus32x2_src, elemusA)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 2; indx++) if (vecus32x2_res[indx] != expectedus2_1[indx]) abort (); vst1_u32 (vecus32x2_res, vmul_n_u32 (vecus32x2_src, elemusB)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 2; indx++) if (vecus32x2_res[indx] != expectedus2_2[indx]) abort (); @@ -271,24 +283,28 @@ check_v4si (int32_t elemsA, int32_t elemsB, int32_t elemsC, int32_t elemsD) vst1q_s32 (vecs32x4_res, vmulq_n_s32 (vecs32x4_src, elemsA)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 4; indx++) if (vecs32x4_res[indx] != expecteds4_1[indx]) abort (); vst1q_s32 (vecs32x4_res, vmulq_n_s32 (vecs32x4_src, elemsB)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 4; indx++) if (vecs32x4_res[indx] != expecteds4_2[indx]) abort (); vst1q_s32 (vecs32x4_res, vmulq_n_s32 (vecs32x4_src, elemsC)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 4; indx++) if (vecs32x4_res[indx] != expecteds4_3[indx]) abort (); vst1q_s32 (vecs32x4_res, vmulq_n_s32 (vecs32x4_src, elemsD)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 4; indx++) if (vecs32x4_res[indx] != expecteds4_4[indx]) abort (); @@ -305,24 +321,28 @@ check_v4si_unsigned (uint32_t elemusA, uint32_t elemusB, uint32_t elemusC, vst1q_u32 (vecus32x4_res, vmulq_n_u32 (vecus32x4_src, elemusA)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 4; indx++) if (vecus32x4_res[indx] != expectedus4_1[indx]) abort (); vst1q_u32 (vecus32x4_res, vmulq_n_u32 (vecus32x4_src, elemusB)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 4; indx++) if (vecus32x4_res[indx] != expectedus4_2[indx]) abort (); vst1q_u32 (vecus32x4_res, vmulq_n_u32 (vecus32x4_src, elemusC)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 4; indx++) if (vecus32x4_res[indx] != expectedus4_3[indx]) abort (); vst1q_u32 (vecus32x4_res, vmulq_n_u32 (vecus32x4_src, elemusD)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 4; indx++) if (vecus32x4_res[indx] != expectedus4_4[indx]) abort (); @@ -341,24 +361,28 @@ check_v4hi (int16_t elemhA, int16_t elemhB, int16_t elemhC, int16_t elemhD) vst1_s16 (vech16x4_res, vmul_n_s16 (vech16x4_src, elemhA)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 4; indx++) if (vech16x4_res[indx] != expectedh4_1[indx]) abort (); vst1_s16 (vech16x4_res, vmul_n_s16 (vech16x4_src, elemhB)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 4; indx++) if (vech16x4_res[indx] != expectedh4_2[indx]) abort (); vst1_s16 (vech16x4_res, vmul_n_s16 (vech16x4_src, elemhC)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 4; indx++) if (vech16x4_res[indx] != expectedh4_3[indx]) abort (); vst1_s16 (vech16x4_res, vmul_n_s16 (vech16x4_src, elemhD)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 4; indx++) if (vech16x4_res[indx] != expectedh4_4[indx]) abort (); @@ -375,24 +399,28 @@ check_v4hi_unsigned (uint16_t elemuhA, uint16_t elemuhB, uint16_t elemuhC, vst1_u16 (vecuh16x4_res, vmul_n_u16 (vecuh16x4_src, elemuhA)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 4; indx++) if (vecuh16x4_res[indx] != expecteduh4_1[indx]) abort (); vst1_u16 (vecuh16x4_res, vmul_n_u16 (vecuh16x4_src, elemuhB)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 4; indx++) if (vecuh16x4_res[indx] != expecteduh4_2[indx]) abort (); vst1_u16 (vecuh16x4_res, vmul_n_u16 (vecuh16x4_src, elemuhC)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 4; indx++) if (vecuh16x4_res[indx] != expecteduh4_3[indx]) abort (); vst1_u16 (vecuh16x4_res, vmul_n_u16 (vecuh16x4_src, elemuhD)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 4; indx++) if (vecuh16x4_res[indx] != expecteduh4_4[indx]) abort (); @@ -411,48 +439,56 @@ check_v8hi (int16_t elemhA, int16_t elemhB, int16_t elemhC, int16_t elemhD, vst1q_s16 (vech16x8_res, vmulq_n_s16 (vech16x8_src, elemhA)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 8; indx++) if (vech16x8_res[indx] != expectedh8_1[indx]) abort (); vst1q_s16 (vech16x8_res, vmulq_n_s16 (vech16x8_src, elemhB)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 8; indx++) if (vech16x8_res[indx] != expectedh8_2[indx]) abort (); vst1q_s16 (vech16x8_res, vmulq_n_s16 (vech16x8_src, elemhC)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 8; indx++) if (vech16x8_res[indx] != expectedh8_3[indx]) abort (); vst1q_s16 (vech16x8_res, vmulq_n_s16 (vech16x8_src, elemhD)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 8; indx++) if (vech16x8_res[indx] != expectedh8_4[indx]) abort (); vst1q_s16 (vech16x8_res, vmulq_n_s16 (vech16x8_src, elemhE)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 8; indx++) if (vech16x8_res[indx] != expectedh8_5[indx]) abort (); vst1q_s16 (vech16x8_res, vmulq_n_s16 (vech16x8_src, elemhF)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 8; indx++) if (vech16x8_res[indx] != expectedh8_6[indx]) abort (); vst1q_s16 (vech16x8_res, vmulq_n_s16 (vech16x8_src, elemhG)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 8; indx++) if (vech16x8_res[indx] != expectedh8_7[indx]) abort (); vst1q_s16 (vech16x8_res, vmulq_n_s16 (vech16x8_src, elemhH)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 8; indx++) if (vech16x8_res[indx] != expectedh8_8[indx]) abort (); @@ -470,48 +506,56 @@ check_v8hi_unsigned (uint16_t elemuhA, uint16_t elemuhB, uint16_t elemuhC, vst1q_u16 (vecuh16x8_res, vmulq_n_u16 (vecuh16x8_src, elemuhA)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 8; indx++) if (vecuh16x8_res[indx] != expecteduh8_1[indx]) abort (); vst1q_u16 (vecuh16x8_res, vmulq_n_u16 (vecuh16x8_src, elemuhB)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 8; indx++) if (vecuh16x8_res[indx] != expecteduh8_2[indx]) abort (); vst1q_u16 (vecuh16x8_res, vmulq_n_u16 (vecuh16x8_src, elemuhC)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 8; indx++) if (vecuh16x8_res[indx] != expecteduh8_3[indx]) abort (); vst1q_u16 (vecuh16x8_res, vmulq_n_u16 (vecuh16x8_src, elemuhD)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 8; indx++) if (vecuh16x8_res[indx] != expecteduh8_4[indx]) abort (); vst1q_u16 (vecuh16x8_res, vmulq_n_u16 (vecuh16x8_src, elemuhE)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 8; indx++) if (vecuh16x8_res[indx] != expecteduh8_5[indx]) abort (); vst1q_u16 (vecuh16x8_res, vmulq_n_u16 (vecuh16x8_src, elemuhF)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 8; indx++) if (vecuh16x8_res[indx] != expecteduh8_6[indx]) abort (); vst1q_u16 (vecuh16x8_res, vmulq_n_u16 (vecuh16x8_src, elemuhG)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 8; indx++) if (vecuh16x8_res[indx] != expecteduh8_7[indx]) abort (); vst1q_u16 (vecuh16x8_res, vmulq_n_u16 (vecuh16x8_src, elemuhH)); + asm volatile ("" : : : "memory"); for (indx = 0; indx < 8; indx++) if (vecuh16x8_res[indx] != expecteduh8_8[indx]) abort (); diff --git a/gcc/testsuite/gcc.target/aarch64/sve/cond_unary_4.c b/gcc/testsuite/gcc.target/aarch64/sve/cond_unary_4.c index 4604365..a491f899 100644 --- a/gcc/testsuite/gcc.target/aarch64/sve/cond_unary_4.c +++ b/gcc/testsuite/gcc.target/aarch64/sve/cond_unary_4.c @@ -56,7 +56,11 @@ TEST_ALL (DEF_LOOP) we're relying on combine to merge a SEL and an arithmetic operation, and the SEL doesn't allow the "false" value to be zero when the "true" value is a register. */ -/* { dg-final { scan-assembler-times {\tmovprfx\tz[0-9]+, z[0-9]+\n} 14 } } */ +/* { dg-final { scan-assembler-times {\tmovprfx\tz[0-9]+, z[0-9]+\n} 7 } } */ +/* { dg-final { scan-assembler-times {\tmovprfx\tz[0-9]+\.b, p[0-7]/z, z[0-9]+\.b} 1 } } */ +/* { dg-final { scan-assembler-times {\tmovprfx\tz[0-9]+\.h, p[0-7]/z, z[0-9]+\.h} 2 } } */ +/* { dg-final { scan-assembler-times {\tmovprfx\tz[0-9]+\.s, p[0-7]/z, z[0-9]+\.s} 2 } } */ +/* { dg-final { scan-assembler-times {\tmovprfx\tz[0-9]+\.d, p[0-7]/z, z[0-9]+\.d} 2 } } */ /* { dg-final { scan-assembler-not {\tmov\tz[^\n]*z} } } */ /* { dg-final { scan-assembler-not {\tsel\t} } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/sve/pr93183.c b/gcc/testsuite/gcc.target/aarch64/sve/pr93183.c new file mode 100644 index 0000000..8d1ee41 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/sve/pr93183.c @@ -0,0 +1,21 @@ +/* { dg-do compile } */ +/* { dg-options "-O3" } */ + +typedef unsigned char uint8_t; + +static inline uint8_t +x264_clip_uint8(uint8_t x) +{ + uint8_t t = -x; + uint8_t t1 = x & ~63; + return (t1 != 0) ? t : x; +} + +void +mc_weight(uint8_t *restrict dst, uint8_t *restrict src, int n) +{ + for (int x = 0; x < n*16; x++) + dst[x] = x264_clip_uint8(src[x]); +} + +/* { dg-final { scan-assembler-not {\tsel} } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/sve/pred-cond-reduc.c b/gcc/testsuite/gcc.target/aarch64/sve/pred-cond-reduc.c new file mode 100644 index 0000000..bd53025 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/sve/pred-cond-reduc.c @@ -0,0 +1,18 @@ +/* { dg-do assemble { target aarch64_asm_sve_ok } } */ +/* { dg-options "-O3 --save-temps" } */ + +#include <stdint.h> + +int32_t f (int32_t *restrict array, int len, int min) +{ + int32_t iSum = 0; + + for (int i=0; i<len; i++) { + if (array[i] >= min) + iSum += array[i]; + } + return iSum; +} + + +/* { dg-final { scan-assembler-not {\tsel\tz[0-9]+\.s, p1, z[0-9]+\.s, z[0-9]+\.s} } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/sve/pred-not-gen-1.c b/gcc/testsuite/gcc.target/aarch64/sve/pred-not-gen-1.c new file mode 100644 index 0000000..2c06564 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/sve/pred-not-gen-1.c @@ -0,0 +1,23 @@ +/* { dg-do assemble { target aarch64_asm_sve_ok } } */ +/* { dg-options "-O3 --save-temps" } */ + +/* +** f10: +** ... +** ld1d z1.d, p0/z, \[x1, x5, lsl 3\] +** fcmgt p2.d, p0/z, z1.d, #0.0 +** ld1d z2.d, p2/z, \[x2, x5, lsl 3\] +** not p1.b, p0/z, p2.b +** ld1d z0.d, p1/z, \[x3, x5, lsl 3\] +** ... +*/ + +void f10(double * restrict z, double * restrict w, double * restrict x, double * restrict y, int n) +{ + for (int i = 0; i < n; i++) { + z[i] = (w[i] > 0) ? x[i] + w[i] : y[i] - w[i]; + } +} + +/* { dg-final { scan-assembler-not {\tbic\t} } } */ +/* { dg-final { scan-assembler-times {\tnot\tp[0-9]+\.b, p[0-9]+/z, p[0-9]+\.b\n} 1 } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/sve/pred-not-gen-2.c b/gcc/testsuite/gcc.target/aarch64/sve/pred-not-gen-2.c new file mode 100644 index 0000000..0c3b78d --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/sve/pred-not-gen-2.c @@ -0,0 +1,23 @@ +/* { dg-do assemble { target aarch64_asm_sve_ok } } */ +/* { dg-options "-O3 --save-temps" } */ + +/* +** f11: +** ... +** ld1d z0.d, p0/z, \[x1, x2, lsl 3\] +** fcmgt p2.d, p3/z, z0.d, #0.0 +** fcmgt p1.d, p0/z, z0.d, #0.0 +** not p1.b, p0/z, p1.b +** ld1d z1.d, p1/z, \[x3, x2, lsl 3\] +** ... +*/ + +void f11(double * restrict z, double * restrict w, double * restrict x, double * restrict y, int n) +{ + for (int i = 0; i < n; i++) { + z[i] = (w[i] > 0) ? w[i] : y[i]; + } +} + +/* { dg-final { scan-assembler-not {\tbic\t} } } */ +/* { dg-final { scan-assembler-times {\tnot\tp[0-9]+\.b, p[0-9]+/z, p[0-9]+\.b\n} 1 } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/sve/pred-not-gen-3.c b/gcc/testsuite/gcc.target/aarch64/sve/pred-not-gen-3.c new file mode 100644 index 0000000..248f8ab --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/sve/pred-not-gen-3.c @@ -0,0 +1,21 @@ +/* { dg-do assemble { target aarch64_asm_sve_ok } } */ +/* { dg-options "-O3 --save-temps" } */ + +/* +** f12: +** ... +** ld1w z1.s, p0/z, \[x1, x2, lsl 2\] +** cmple p1.s, p0/z, z1.s, #0 +** ld1w z0.s, p1/z, \[x3, x2, lsl 2\] +** ... +*/ + +void f12(int * restrict z, int * restrict w, int * restrict x, int * restrict y, int n) +{ + for (int i = 0; i < n; i++) { + z[i] = (w[i] > 0) ? w[i] : y[i]; + } +} + +/* { dg-final { scan-assembler-not {\tbic\t} } } */ +/* { dg-final { scan-assembler-not {\tnot\tp[0-9]+\.b, p[0-9]+/z, p[0-9]+\.b\n} } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/sve/pred-not-gen-4.c b/gcc/testsuite/gcc.target/aarch64/sve/pred-not-gen-4.c new file mode 100644 index 0000000..9620030 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/sve/pred-not-gen-4.c @@ -0,0 +1,14 @@ +/* { dg-do assemble { target aarch64_asm_sve_ok } } */ +/* { dg-options "-O3 --save-temps" } */ + +#include <math.h> + +void f13(double * restrict z, double * restrict w, double * restrict x, double * restrict y, int n) +{ + for (int i = 0; i < n; i++) { + z[i] = (isunordered(w[i], 0)) ? x[i] + w[i] : y[i] - w[i]; + } +} + +/* { dg-final { scan-assembler-not {\tbic\t} } } */ +/* { dg-final { scan-assembler-times {\tnot\tp[0-9]+\.b, p[0-9]+/z, p[0-9]+\.b\n} 1 } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/vclz.c b/gcc/testsuite/gcc.target/aarch64/vclz.c index a36ee44..ca4d174 100644 --- a/gcc/testsuite/gcc.target/aarch64/vclz.c +++ b/gcc/testsuite/gcc.target/aarch64/vclz.c @@ -66,22 +66,62 @@ extern void abort (void); #define CLZ_INST(reg_len, data_len, is_signed) \ CONCAT1 (vclz, POSTFIX (reg_len, data_len, is_signed)) -#define RUN_TEST(test_set, answ_set, reg_len, data_len, is_signed, n) \ - INHIB_OPTIMIZATION; \ - a = LOAD_INST (reg_len, data_len, is_signed) (test_set); \ - b = LOAD_INST (reg_len, data_len, is_signed) (answ_set); \ - a = CLZ_INST (reg_len, data_len, is_signed) (a); \ - for (i = 0; i < n; i++) \ - if (a [i] != b [i]) \ - return 1; +#define BUILD_TEST(type, size, lanes) \ +int __attribute__((noipa,noinline)) \ +run_test##type##size##x##lanes (int##size##_t* test_set, \ + int##size##_t* answ_set, \ + int reg_len, int data_len, \ + int n) \ +{ \ + int i; \ + INHIB_OPTIMIZATION; \ + int##size##x##lanes##_t a = vld1##type##size (test_set); \ + int##size##x##lanes##_t b = vld1##type##size (answ_set); \ + a = vclz##type##size (a); \ + for (i = 0; i < n; i++){ \ + if (a [i] != b [i]) \ + return 1; \ + } \ + return 0; \ +} + +/* unsigned inputs */ +#define U_BUILD_TEST(type, size, lanes) \ +int __attribute__((noipa,noinline)) \ +run_test##type##size##x##lanes (uint##size##_t* test_set, \ + uint##size##_t* answ_set, \ + int reg_len, int data_len, \ + int n) \ +{ \ + int i; \ + INHIB_OPTIMIZATION; \ + uint##size##x##lanes##_t a = vld1##type##size (test_set); \ + uint##size##x##lanes##_t b = vld1##type##size (answ_set); \ + a = vclz##type##size (a); \ + for (i = 0; i < n; i++){ \ + if (a [i] != b [i]) \ + return 1; \ + } \ + return 0; \ +} + +BUILD_TEST (_s, 8, 8) +BUILD_TEST (_s, 16, 4) +BUILD_TEST (_s, 32, 2) +BUILD_TEST (q_s, 8, 16) +BUILD_TEST (q_s, 16, 8) +BUILD_TEST (q_s, 32, 4) + +U_BUILD_TEST (_u, 8, 8) +U_BUILD_TEST (_u, 16, 4) +U_BUILD_TEST (_u, 32, 2) +U_BUILD_TEST (q_u, 8, 16) +U_BUILD_TEST (q_u, 16, 8) +U_BUILD_TEST (q_u, 32, 4) int __attribute__ ((noinline)) test_vclz_s8 () { - int i; - int8x8_t a; - int8x8_t b; - int8_t test_set0[8] = { TEST0, TEST1, TEST2, TEST3, TEST4, TEST5, TEST6, TEST7 @@ -98,22 +138,18 @@ test_vclz_s8 () 0, 0, 0, 0, 0, 0, 0, 0 }; - RUN_TEST (test_set0, answ_set0, 64, 8, 1, 8); - RUN_TEST (test_set1, answ_set1, 64, 8, 1, 1); + int o1 = run_test_s8x8 (test_set0, answ_set0, 64, 8, 8); + int o2 = run_test_s8x8 (test_set1, answ_set1, 64, 8, 1); - return 0; + return o1||o2; } /* Double scan-assembler-times to take account of unsigned functions. */ -/* { dg-final { scan-assembler-times "clz\\tv\[0-9\]+\.8b, v\[0-9\]+\.8b" 4 } } */ +/* { dg-final { scan-assembler-times "clz\\tv\[0-9\]+\.8b, v\[0-9\]+\.8b" 2 } } */ int __attribute__ ((noinline)) test_vclz_s16 () { - int i; - int16x4_t a; - int16x4_t b; - int16_t test_set0[4] = { TEST0, TEST1, TEST2, TEST3 }; int16_t test_set1[4] = { TEST4, TEST5, TEST6, TEST7 }; int16_t test_set2[4] = { TEST8, TEST9, TEST10, TEST11 }; @@ -126,25 +162,21 @@ test_vclz_s16 () int16_t answ_set3[4] = { 4, 3, 2, 1 }; int16_t answ_set4[4] = { 0, 0, 0, 0 }; - RUN_TEST (test_set0, answ_set0, 64, 16, 1, 4); - RUN_TEST (test_set1, answ_set1, 64, 16, 1, 4); - RUN_TEST (test_set2, answ_set2, 64, 16, 1, 4); - RUN_TEST (test_set3, answ_set3, 64, 16, 1, 4); - RUN_TEST (test_set4, answ_set4, 64, 16, 1, 1); + int o1 = run_test_s16x4 (test_set0, answ_set0, 64, 16, 4); + int o2 = run_test_s16x4 (test_set1, answ_set1, 64, 16, 4); + int o3 = run_test_s16x4 (test_set2, answ_set2, 64, 16, 4); + int o4 = run_test_s16x4 (test_set3, answ_set3, 64, 16, 4); + int o5 = run_test_s16x4 (test_set4, answ_set4, 64, 16, 1); - return 0; + return o1||o2||o3||o4||o5; } /* Double scan-assembler-times to take account of unsigned functions. */ -/* { dg-final { scan-assembler-times "clz\\tv\[0-9\]+\.4h, v\[0-9\]+\.4h" 10} } */ +/* { dg-final { scan-assembler-times "clz\\tv\[0-9\]+\.4h, v\[0-9\]+\.4h" 2} } */ int __attribute__ ((noinline)) test_vclz_s32 () { - int i; - int32x2_t a; - int32x2_t b; - int32_t test_set0[2] = { TEST0, TEST1 }; int32_t test_set1[2] = { TEST2, TEST3 }; int32_t test_set2[2] = { TEST4, TEST5 }; @@ -181,37 +213,34 @@ test_vclz_s32 () int32_t answ_set15[2] = { 2, 1 }; int32_t answ_set16[2] = { 0, 0 }; - RUN_TEST (test_set0, answ_set0, 64, 32, 1, 2); - RUN_TEST (test_set1, answ_set1, 64, 32, 1, 2); - RUN_TEST (test_set2, answ_set2, 64, 32, 1, 2); - RUN_TEST (test_set3, answ_set3, 64, 32, 1, 2); - RUN_TEST (test_set4, answ_set4, 64, 32, 1, 2); - RUN_TEST (test_set5, answ_set5, 64, 32, 1, 2); - RUN_TEST (test_set6, answ_set6, 64, 32, 1, 2); - RUN_TEST (test_set7, answ_set7, 64, 32, 1, 2); - RUN_TEST (test_set8, answ_set8, 64, 32, 1, 2); - RUN_TEST (test_set9, answ_set9, 64, 32, 1, 2); - RUN_TEST (test_set10, answ_set10, 64, 32, 1, 2); - RUN_TEST (test_set11, answ_set11, 64, 32, 1, 2); - RUN_TEST (test_set12, answ_set12, 64, 32, 1, 2); - RUN_TEST (test_set13, answ_set13, 64, 32, 1, 2); - RUN_TEST (test_set14, answ_set14, 64, 32, 1, 2); - RUN_TEST (test_set15, answ_set15, 64, 32, 1, 2); - RUN_TEST (test_set16, answ_set16, 64, 32, 1, 1); - - return 0; + int o1 = run_test_s32x2 (test_set0, answ_set0, 64, 32, 2); + int o2 = run_test_s32x2 (test_set1, answ_set1, 64, 32, 2); + int o3 = run_test_s32x2 (test_set2, answ_set2, 64, 32, 2); + int o4 = run_test_s32x2 (test_set3, answ_set3, 64, 32, 2); + int o5 = run_test_s32x2 (test_set4, answ_set4, 64, 32, 2); + int o6 = run_test_s32x2 (test_set5, answ_set5, 64, 32, 2); + int o7 = run_test_s32x2 (test_set6, answ_set6, 64, 32, 2); + int o8 = run_test_s32x2 (test_set7, answ_set7, 64, 32, 2); + int o9 = run_test_s32x2 (test_set8, answ_set8, 64, 32, 2); + int o10 = run_test_s32x2 (test_set9, answ_set9, 64, 32, 2); + int o11 = run_test_s32x2 (test_set10, answ_set10, 64, 32, 2); + int o12 = run_test_s32x2 (test_set11, answ_set11, 64, 32, 2); + int o13 = run_test_s32x2 (test_set12, answ_set12, 64, 32, 2); + int o14 = run_test_s32x2 (test_set13, answ_set13, 64, 32, 2); + int o15 = run_test_s32x2 (test_set14, answ_set14, 64, 32, 2); + int o16 = run_test_s32x2 (test_set15, answ_set15, 64, 32, 2); + int o17 = run_test_s32x2 (test_set16, answ_set16, 64, 32, 1); + + return o1||o2||o3||o4||o5||o6||o7||o8||o9||o10||o11||o12||o13||o14 + ||o15||o16||o17; } /* Double scan-assembler-times to take account of unsigned functions. */ -/* { dg-final { scan-assembler-times "clz\\tv\[0-9\]+\.2s, v\[0-9\]+\.2s" 34 } } */ +/* { dg-final { scan-assembler-times "clz\\tv\[0-9\]+\.2s, v\[0-9\]+\.2s" 2 } } */ int __attribute__ ((noinline)) test_vclzq_s8 () { - int i; - int8x16_t a; - int8x16_t b; - int8_t test_set0[16] = { TEST0, TEST1, TEST2, TEST3, TEST4, TEST5, TEST6, TEST7, TEST8, TEST8, TEST8, TEST8, TEST8, TEST8, TEST8, TEST8 @@ -219,8 +248,8 @@ test_vclzq_s8 () int8_t answ_set0[16] = { 8, 7, 6, 5, 4, 3, 2, 1, 0, 0, 0, 0, 0, 0, 0, 0 }; - RUN_TEST (test_set0, answ_set0, 128, 8, 1, 9); - return 0; + int o1 = run_testq_s8x16 (test_set0, answ_set0, 128, 8, 9); + return o1; } /* Double scan-assembler-times to take account of unsigned functions. */ @@ -229,10 +258,6 @@ test_vclzq_s8 () int __attribute__ ((noinline)) test_vclzq_s16 () { - int i; - int16x8_t a; - int16x8_t b; - int16_t test_set0[8] = { TEST0, TEST1, TEST2, TEST3, TEST4, TEST5, TEST6, TEST7 }; @@ -252,23 +277,19 @@ test_vclzq_s16 () int16_t answ_set2[8] = { 0, 0, 0, 0, 0, 0, 0, 0 }; - RUN_TEST (test_set0, answ_set0, 128, 16, 1, 8); - RUN_TEST (test_set1, answ_set1, 128, 16, 1, 8); - RUN_TEST (test_set2, answ_set2, 128, 16, 1, 1); + int o1 = run_testq_s16x8 (test_set0, answ_set0, 128, 16, 8); + int o2 = run_testq_s16x8 (test_set1, answ_set1, 128, 16, 8); + int o3 = run_testq_s16x8 (test_set2, answ_set2, 128, 16, 1); - return 0; + return o1||o2||o3; } /* Double scan-assembler-times to take account of unsigned functions. */ -/* { dg-final { scan-assembler-times "clz\\tv\[0-9\]+\.8h, v\[0-9\]+\.8h" 6 } } */ +/* { dg-final { scan-assembler-times "clz\\tv\[0-9\]+\.8h, v\[0-9\]+\.8h" 2 } } */ int __attribute__ ((noinline)) test_vclzq_s32 () { - int i; - int32x4_t a; - int32x4_t b; - int32_t test_set0[4] = { TEST0, TEST1, TEST2, TEST3 }; int32_t test_set1[4] = { TEST4, TEST5, TEST6, TEST7 }; int32_t test_set2[4] = { TEST8, TEST9, TEST10, TEST11 }; @@ -289,27 +310,23 @@ test_vclzq_s32 () int32_t answ_set7[4] = { 4, 3, 2, 1 }; int32_t answ_set8[4] = { 0, 0, 0, 0 }; - RUN_TEST (test_set0, answ_set0, 128, 32, 1, 4); - RUN_TEST (test_set1, answ_set1, 128, 32, 1, 4); - RUN_TEST (test_set2, answ_set2, 128, 32, 1, 4); - RUN_TEST (test_set3, answ_set3, 128, 32, 1, 4); - RUN_TEST (test_set4, answ_set4, 128, 32, 1, 1); + int o1 = run_testq_s32x4 (test_set0, answ_set0, 128, 32, 4); + int o2 = run_testq_s32x4 (test_set1, answ_set1, 128, 32, 4); + int o3 = run_testq_s32x4 (test_set2, answ_set2, 128, 32, 4); + int o4 = run_testq_s32x4 (test_set3, answ_set3, 128, 32, 4); + int o5 = run_testq_s32x4 (test_set4, answ_set4, 128, 32, 1); - return 0; + return o1||o2||o3||o4||o5; } /* Double scan-assembler-times to take account of unsigned functions. */ -/* { dg-final { scan-assembler-times "clz\\tv\[0-9\]+\.4s, v\[0-9\]+\.4s" 10 } } */ +/* { dg-final { scan-assembler-times "clz\\tv\[0-9\]+\.4s, v\[0-9\]+\.4s" 2 } } */ /* Unsigned versions. */ int __attribute__ ((noinline)) test_vclz_u8 () { - int i; - uint8x8_t a; - uint8x8_t b; - uint8_t test_set0[8] = { TEST0, TEST1, TEST2, TEST3, TEST4, TEST5, TEST6, TEST7 }; @@ -323,10 +340,10 @@ test_vclz_u8 () 0, 0, 0, 0, 0, 0, 0, 0 }; - RUN_TEST (test_set0, answ_set0, 64, 8, 0, 8); - RUN_TEST (test_set1, answ_set1, 64, 8, 0, 1); + int o1 = run_test_u8x8 (test_set0, answ_set0, 64, 8, 8); + int o2 = run_test_u8x8 (test_set1, answ_set1, 64, 8, 1); - return 0; + return o1||o2; } /* ASM scan near test for signed version. */ @@ -334,10 +351,6 @@ test_vclz_u8 () int __attribute__ ((noinline)) test_vclz_u16 () { - int i; - uint16x4_t a; - uint16x4_t b; - uint16_t test_set0[4] = { TEST0, TEST1, TEST2, TEST3 }; uint16_t test_set1[4] = { TEST4, TEST5, TEST6, TEST7 }; uint16_t test_set2[4] = { TEST8, TEST9, TEST10, TEST11 }; @@ -350,13 +363,13 @@ test_vclz_u16 () uint16_t answ_set3[4] = { 4, 3, 2, 1 }; uint16_t answ_set4[4] = { 0, 0, 0, 0 }; - RUN_TEST (test_set0, answ_set0, 64, 16, 0, 4); - RUN_TEST (test_set1, answ_set1, 64, 16, 0, 4); - RUN_TEST (test_set2, answ_set2, 64, 16, 0, 4); - RUN_TEST (test_set3, answ_set3, 64, 16, 0, 4); - RUN_TEST (test_set4, answ_set4, 64, 16, 0, 1); + int o1 = run_test_u16x4 (test_set0, answ_set0, 64, 16, 4); + int o2 = run_test_u16x4 (test_set1, answ_set1, 64, 16, 4); + int o3 = run_test_u16x4 (test_set2, answ_set2, 64, 16, 4); + int o4 = run_test_u16x4 (test_set3, answ_set3, 64, 16, 4); + int o5 = run_test_u16x4 (test_set4, answ_set4, 64, 16, 1); - return 0; + return o1||o2||o3||o4||o5; } /* ASM scan near test for signed version. */ @@ -364,10 +377,6 @@ test_vclz_u16 () int __attribute__ ((noinline)) test_vclz_u32 () { - int i; - uint32x2_t a; - uint32x2_t b; - uint32_t test_set0[2] = { TEST0, TEST1 }; uint32_t test_set1[2] = { TEST2, TEST3 }; uint32_t test_set2[2] = { TEST4, TEST5 }; @@ -404,25 +413,26 @@ test_vclz_u32 () uint32_t answ_set15[2] = { 2, 1 }; uint32_t answ_set16[2] = { 0, 0 }; - RUN_TEST (test_set0, answ_set0, 64, 32, 0, 2); - RUN_TEST (test_set1, answ_set1, 64, 32, 0, 2); - RUN_TEST (test_set2, answ_set2, 64, 32, 0, 2); - RUN_TEST (test_set3, answ_set3, 64, 32, 0, 2); - RUN_TEST (test_set4, answ_set4, 64, 32, 0, 2); - RUN_TEST (test_set5, answ_set5, 64, 32, 0, 2); - RUN_TEST (test_set6, answ_set6, 64, 32, 0, 2); - RUN_TEST (test_set7, answ_set7, 64, 32, 0, 2); - RUN_TEST (test_set8, answ_set8, 64, 32, 0, 2); - RUN_TEST (test_set9, answ_set9, 64, 32, 0, 2); - RUN_TEST (test_set10, answ_set10, 64, 32, 0, 2); - RUN_TEST (test_set11, answ_set11, 64, 32, 0, 2); - RUN_TEST (test_set12, answ_set12, 64, 32, 0, 2); - RUN_TEST (test_set13, answ_set13, 64, 32, 0, 2); - RUN_TEST (test_set14, answ_set14, 64, 32, 0, 2); - RUN_TEST (test_set15, answ_set15, 64, 32, 0, 2); - RUN_TEST (test_set16, answ_set16, 64, 32, 0, 1); - - return 0; + int o1 = run_test_u32x2 (test_set0, answ_set0, 64, 32, 2); + int o2 = run_test_u32x2 (test_set1, answ_set1, 64, 32, 2); + int o3 = run_test_u32x2 (test_set2, answ_set2, 64, 32, 2); + int o4 = run_test_u32x2 (test_set3, answ_set3, 64, 32, 2); + int o5 = run_test_u32x2 (test_set4, answ_set4, 64, 32, 2); + int o6 = run_test_u32x2 (test_set5, answ_set5, 64, 32, 2); + int o7 = run_test_u32x2 (test_set6, answ_set6, 64, 32, 2); + int o8 = run_test_u32x2 (test_set7, answ_set7, 64, 32, 2); + int o9 = run_test_u32x2 (test_set8, answ_set8, 64, 32, 2); + int o10 = run_test_u32x2 (test_set9, answ_set9, 64, 32, 2); + int o11 = run_test_u32x2 (test_set10, answ_set10, 64, 32, 2); + int o12 = run_test_u32x2 (test_set11, answ_set11, 64, 32, 2); + int o13 = run_test_u32x2 (test_set12, answ_set12, 64, 32, 2); + int o14 = run_test_u32x2 (test_set13, answ_set13, 64, 32, 2); + int o15 = run_test_u32x2 (test_set14, answ_set14, 64, 32, 2); + int o16 = run_test_u32x2 (test_set15, answ_set15, 64, 32, 2); + int o17 = run_test_u32x2 (test_set16, answ_set16, 64, 32, 1); + + return o1||o2||o3||o4||o5||o6||o7||o8||o9||o10||o11||o12||o13||o14 + ||o15||o16||o17; } /* ASM scan near test for signed version. */ @@ -441,9 +451,9 @@ test_vclzq_u8 () uint8_t answ_set0[16] = { 8, 7, 6, 5, 4, 3, 2, 1, 0, 0, 0, 0, 0, 0, 0, 0 }; - RUN_TEST (test_set0, answ_set0, 128, 8, 0, 9); + int o1 = run_testq_u8x16 (test_set0, answ_set0, 128, 8, 9); - return 0; + return o1; } /* ASM scan near test for signed version. */ @@ -476,11 +486,11 @@ test_vclzq_u16 () 0, 0, 0, 0, 0, 0, 0, 0 }; - RUN_TEST (test_set0, answ_set0, 128, 16, 0, 8); - RUN_TEST (test_set1, answ_set1, 128, 16, 0, 8); - RUN_TEST (test_set2, answ_set2, 128, 16, 0, 1); + int o1 = run_testq_u16x8 (test_set0, answ_set0, 128, 16, 8); + int o2 = run_testq_u16x8 (test_set1, answ_set1, 128, 16, 8); + int o3 = run_testq_u16x8 (test_set2, answ_set2, 128, 16, 1); - return 0; + return o1||o2||o3; } /* ASM scan near test for signed version. */ @@ -488,10 +498,6 @@ test_vclzq_u16 () int __attribute__ ((noinline)) test_vclzq_u32 () { - int i; - uint32x4_t a; - uint32x4_t b; - uint32_t test_set0[4] = { TEST0, TEST1, TEST2, TEST3 }; uint32_t test_set1[4] = { TEST4, TEST5, TEST6, TEST7 }; uint32_t test_set2[4] = { TEST8, TEST9, TEST10, TEST11 }; @@ -512,13 +518,13 @@ test_vclzq_u32 () uint32_t answ_set7[4] = { 4, 3, 2, 1 }; uint32_t answ_set8[4] = { 0, 0, 0, 0 }; - RUN_TEST (test_set0, answ_set0, 128, 32, 0, 4); - RUN_TEST (test_set1, answ_set1, 128, 32, 0, 4); - RUN_TEST (test_set2, answ_set2, 128, 32, 0, 4); - RUN_TEST (test_set3, answ_set3, 128, 32, 0, 4); - RUN_TEST (test_set4, answ_set4, 128, 32, 0, 1); + int o1 = run_testq_u32x4 (test_set0, answ_set0, 128, 32, 4); + int o2 = run_testq_u32x4 (test_set1, answ_set1, 128, 32, 4); + int o3 = run_testq_u32x4 (test_set2, answ_set2, 128, 32, 4); + int o4 = run_testq_u32x4 (test_set3, answ_set3, 128, 32, 4); + int o5 = run_testq_u32x4 (test_set4, answ_set4, 128, 32, 1); - return 0; + return o1||o2||o3||o4||o5; } /* ASM scan near test for signed version. */ diff --git a/gcc/testsuite/gcc.target/aarch64/vneg_s.c b/gcc/testsuite/gcc.target/aarch64/vneg_s.c index 6947526..8ddc4d2 100644 --- a/gcc/testsuite/gcc.target/aarch64/vneg_s.c +++ b/gcc/testsuite/gcc.target/aarch64/vneg_s.c @@ -31,49 +31,24 @@ extern void abort (void); -#define CONCAT(a, b) a##b -#define CONCAT1(a, b) CONCAT (a, b) -#define REG_INFEX64 _ -#define REG_INFEX128 q_ -#define REG_INFEX(reg_len) REG_INFEX##reg_len -#define POSTFIX(reg_len, data_len) \ - CONCAT1 (REG_INFEX (reg_len), s##data_len) -#define DATA_TYPE_32 float -#define DATA_TYPE_64 double -#define DATA_TYPE(data_len) DATA_TYPE_##data_len - -#define FORCE_SIMD_INST64_8(data) -#define FORCE_SIMD_INST64_16(data) -#define FORCE_SIMD_INST64_32(data) -#define FORCE_SIMD_INST64_64(data) force_simd (data) -#define FORCE_SIMD_INST128_8(data) -#define FORCE_SIMD_INST128_16(data) -#define FORCE_SIMD_INST128_32(data) -#define FORCE_SIMD_INST128_64(data) - -#define FORCE_SIMD_INST(reg_len, data_len, data) \ - CONCAT1 (FORCE_SIMD_INST, reg_len##_##data_len) (data) -#define LOAD_INST(reg_len, data_len) \ - CONCAT1 (vld1, POSTFIX (reg_len, data_len)) -#define NEG_INST(reg_len, data_len) \ - CONCAT1 (vneg, POSTFIX (reg_len, data_len)) - -#define RUN_TEST(test_set, answ_set, reg_len, data_len, n, a, b) \ - { \ - int i; \ - INHIB_OPTIMIZATION; \ - (a) = LOAD_INST (reg_len, data_len) (test_set); \ - (b) = LOAD_INST (reg_len, data_len) (answ_set); \ - FORCE_SIMD_INST (reg_len, data_len, a) \ - a = NEG_INST (reg_len, data_len) (a); \ - FORCE_SIMD_INST (reg_len, data_len, a) \ - for (i = 0; i < n; i++) \ - { \ - INHIB_OPTIMIZATION; \ - if (a[i] != b[i]) \ - return 1; \ - } \ - } +#define BUILD_TEST(type, size, lanes) \ +int __attribute__((noipa,noinline)) \ +run_test##type##size##x##lanes (int##size##_t* test_set, \ + int##size##_t* answ_set, \ + int reg_len, int data_len, int n) \ +{ \ + int i; \ + int##size##x##lanes##_t a = vld1##type##size (test_set); \ + int##size##x##lanes##_t b = vld1##type##size (answ_set); \ + a = vneg##type##size (a); \ + for (i = 0; i < n; i++) \ + { \ + INHIB_OPTIMIZATION; \ + if (a[i] != b[i]) \ + return 1; \ + } \ + return 0; \ +} \ #define RUN_TEST_SCALAR(test_val, answ_val, a, b) \ { \ @@ -87,12 +62,19 @@ extern void abort (void); force_simd (res); \ } +BUILD_TEST (_s, 8, 8) +BUILD_TEST (_s, 16, 4) +BUILD_TEST (_s, 32, 2) +BUILD_TEST (_s, 64, 1) + +BUILD_TEST (q_s, 8, 16) +BUILD_TEST (q_s, 16, 8) +BUILD_TEST (q_s, 32, 4) +BUILD_TEST (q_s, 64, 2) + int __attribute__ ((noinline)) test_vneg_s8 () { - int8x8_t a; - int8x8_t b; - int8_t test_set0[8] = { TEST0, TEST1, TEST2, TEST3, TEST4, TEST5, SCHAR_MAX, SCHAR_MIN }; @@ -100,9 +82,9 @@ test_vneg_s8 () ANSW0, ANSW1, ANSW2, ANSW3, ANSW4, ANSW5, SCHAR_MIN + 1, SCHAR_MIN }; - RUN_TEST (test_set0, answ_set0, 64, 8, 8, a, b); + int o1 = run_test_s8x8 (test_set0, answ_set0, 64, 8, 8); - return 0; + return o1; } /* { dg-final { scan-assembler-times "neg\\tv\[0-9\]+\.8b, v\[0-9\]+\.8b" 1 } } */ @@ -110,29 +92,23 @@ test_vneg_s8 () int __attribute__ ((noinline)) test_vneg_s16 () { - int16x4_t a; - int16x4_t b; - int16_t test_set0[4] = { TEST0, TEST1, TEST2, TEST3 }; int16_t test_set1[4] = { TEST4, TEST5, SHRT_MAX, SHRT_MIN }; int16_t answ_set0[4] = { ANSW0, ANSW1, ANSW2, ANSW3 }; int16_t answ_set1[4] = { ANSW4, ANSW5, SHRT_MIN + 1, SHRT_MIN }; - RUN_TEST (test_set0, answ_set0, 64, 16, 4, a, b); - RUN_TEST (test_set1, answ_set1, 64, 16, 4, a, b); + int o1 = run_test_s16x4 (test_set0, answ_set0, 64, 16, 4); + int o2 = run_test_s16x4 (test_set1, answ_set1, 64, 16, 4); - return 0; + return o1||o2; } -/* { dg-final { scan-assembler-times "neg\\tv\[0-9\]+\.4h, v\[0-9\]+\.4h" 2 } } */ +/* { dg-final { scan-assembler-times "neg\\tv\[0-9\]+\.4h, v\[0-9\]+\.4h" 1 } } */ int __attribute__ ((noinline)) test_vneg_s32 () { - int32x2_t a; - int32x2_t b; - int32_t test_set0[2] = { TEST0, TEST1 }; int32_t test_set1[2] = { TEST2, TEST3 }; int32_t test_set2[2] = { TEST4, TEST5 }; @@ -143,22 +119,19 @@ test_vneg_s32 () int32_t answ_set2[2] = { ANSW4, ANSW5 }; int32_t answ_set3[2] = { INT_MIN + 1, INT_MIN }; - RUN_TEST (test_set0, answ_set0, 64, 32, 2, a, b); - RUN_TEST (test_set1, answ_set1, 64, 32, 2, a, b); - RUN_TEST (test_set2, answ_set2, 64, 32, 2, a, b); - RUN_TEST (test_set3, answ_set3, 64, 32, 2, a, b); + int o1 = run_test_s32x2 (test_set0, answ_set0, 64, 32, 2); + int o2 = run_test_s32x2 (test_set1, answ_set1, 64, 32, 2); + int o3 = run_test_s32x2 (test_set2, answ_set2, 64, 32, 2); + int o4 = run_test_s32x2 (test_set3, answ_set3, 64, 32, 2); - return 0; + return o1||o2||o3||o4; } -/* { dg-final { scan-assembler-times "neg\\tv\[0-9\]+\.2s, v\[0-9\]+\.2s" 4 } } */ +/* { dg-final { scan-assembler-times "neg\\tv\[0-9\]+\.2s, v\[0-9\]+\.2s" 1 } } */ int __attribute__ ((noinline)) test_vneg_s64 () { - int64x1_t a; - int64x1_t b; - int64_t test_set0[1] = { TEST0 }; int64_t test_set1[1] = { TEST1 }; int64_t test_set2[1] = { TEST2 }; @@ -177,16 +150,16 @@ test_vneg_s64 () int64_t answ_set6[1] = { LLONG_MIN + 1 }; int64_t answ_set7[1] = { LLONG_MIN }; - RUN_TEST (test_set0, answ_set0, 64, 64, 1, a, b); - RUN_TEST (test_set1, answ_set1, 64, 64, 1, a, b); - RUN_TEST (test_set2, answ_set2, 64, 64, 1, a, b); - RUN_TEST (test_set3, answ_set3, 64, 64, 1, a, b); - RUN_TEST (test_set4, answ_set4, 64, 64, 1, a, b); - RUN_TEST (test_set5, answ_set5, 64, 64, 1, a, b); - RUN_TEST (test_set6, answ_set6, 64, 64, 1, a, b); - RUN_TEST (test_set7, answ_set7, 64, 64, 1, a, b); + int o1 = run_test_s64x1 (test_set0, answ_set0, 64, 64, 1); + int o2 = run_test_s64x1 (test_set1, answ_set1, 64, 64, 1); + int o3 = run_test_s64x1 (test_set2, answ_set2, 64, 64, 1); + int o4 = run_test_s64x1 (test_set3, answ_set3, 64, 64, 1); + int o5 = run_test_s64x1 (test_set4, answ_set4, 64, 64, 1); + int o6 = run_test_s64x1 (test_set5, answ_set5, 64, 64, 1); + int o7 = run_test_s64x1 (test_set6, answ_set6, 64, 64, 1); + int o8 = run_test_s64x1 (test_set7, answ_set7, 64, 64, 1); - return 0; + return o1||o2||o3||o4||o5||o6||o7||o8; } int __attribute__ ((noinline)) @@ -206,14 +179,11 @@ test_vnegd_s64 () return 0; } -/* { dg-final { scan-assembler-times "neg\\td\[0-9\]+, d\[0-9\]+" 16 } } */ +/* { dg-final { scan-assembler-times "neg\\td\[0-9\]+, d\[0-9\]+" 8 } } */ int __attribute__ ((noinline)) test_vnegq_s8 () { - int8x16_t a; - int8x16_t b; - int8_t test_set0[16] = { TEST0, TEST1, TEST2, TEST3, TEST4, TEST5, SCHAR_MAX, SCHAR_MIN, 4, 8, 15, 16, 23, 42, -1, -2 @@ -224,9 +194,9 @@ test_vnegq_s8 () -4, -8, -15, -16, -23, -42, 1, 2 }; - RUN_TEST (test_set0, answ_set0, 128, 8, 8, a, b); + int o1 = run_testq_s8x16 (test_set0, answ_set0, 128, 8, 8); - return 0; + return o1; } /* { dg-final { scan-assembler-times "neg\\tv\[0-9\]+\.16b, v\[0-9\]+\.16b" 1 } } */ @@ -234,9 +204,6 @@ test_vnegq_s8 () int __attribute__ ((noinline)) test_vnegq_s16 () { - int16x8_t a; - int16x8_t b; - int16_t test_set0[8] = { TEST0, TEST1, TEST2, TEST3, TEST4, TEST5, SHRT_MAX, SHRT_MIN }; @@ -244,9 +211,9 @@ test_vnegq_s16 () ANSW0, ANSW1, ANSW2, ANSW3, ANSW4, ANSW5, SHRT_MIN + 1, SHRT_MIN }; - RUN_TEST (test_set0, answ_set0, 128, 16, 8, a, b); + int o1 = run_testq_s16x8 (test_set0, answ_set0, 128, 16, 8); - return 0; + return o1; } /* { dg-final { scan-assembler-times "neg\\tv\[0-9\]+\.8h, v\[0-9\]+\.8h" 1 } } */ @@ -254,29 +221,23 @@ test_vnegq_s16 () int __attribute__ ((noinline)) test_vnegq_s32 () { - int32x4_t a; - int32x4_t b; - int32_t test_set0[4] = { TEST0, TEST1, TEST2, TEST3 }; int32_t test_set1[4] = { TEST4, TEST5, INT_MAX, INT_MIN }; int32_t answ_set0[4] = { ANSW0, ANSW1, ANSW2, ANSW3 }; int32_t answ_set1[4] = { ANSW4, ANSW5, INT_MIN + 1, INT_MIN }; - RUN_TEST (test_set0, answ_set0, 128, 32, 4, a, b); - RUN_TEST (test_set1, answ_set1, 128, 32, 4, a, b); + int o1 = run_testq_s32x4 (test_set0, answ_set0, 128, 32, 4); + int o2 = run_testq_s32x4 (test_set1, answ_set1, 128, 32, 4); - return 0; + return o1||o2; } -/* { dg-final { scan-assembler-times "neg\\tv\[0-9\]+\.4s, v\[0-9\]+\.4s" 2 } } */ +/* { dg-final { scan-assembler-times "neg\\tv\[0-9\]+\.4s, v\[0-9\]+\.4s" 1 } } */ int __attribute__ ((noinline)) test_vnegq_s64 () { - int64x2_t a; - int64x2_t b; - int64_t test_set0[2] = { TEST0, TEST1 }; int64_t test_set1[2] = { TEST2, TEST3 }; int64_t test_set2[2] = { TEST4, TEST5 }; @@ -287,15 +248,15 @@ test_vnegq_s64 () int64_t answ_set2[2] = { ANSW4, ANSW5 }; int64_t answ_set3[2] = { LLONG_MIN + 1, LLONG_MIN }; - RUN_TEST (test_set0, answ_set0, 128, 64, 2, a, b); - RUN_TEST (test_set1, answ_set1, 128, 64, 2, a, b); - RUN_TEST (test_set2, answ_set2, 128, 64, 2, a, b); - RUN_TEST (test_set3, answ_set3, 128, 64, 2, a, b); + int o1 = run_testq_s64x2 (test_set0, answ_set0, 128, 64, 2); + int o2 = run_testq_s64x2 (test_set1, answ_set1, 128, 64, 2); + int o3 = run_testq_s64x2 (test_set2, answ_set2, 128, 64, 2); + int o4 = run_testq_s64x2 (test_set3, answ_set3, 128, 64, 2); - return 0; + return o1||o2||o2||o4; } -/* { dg-final { scan-assembler-times "neg\\tv\[0-9\]+\.2d, v\[0-9\]+\.2d" 4 } } */ +/* { dg-final { scan-assembler-times "neg\\tv\[0-9\]+\.2d, v\[0-9\]+\.2d" 1 } } */ int main (int argc, char **argv) diff --git a/gcc/testsuite/gcc.target/aarch64/xtn-combine-1.c b/gcc/testsuite/gcc.target/aarch64/xtn-combine-1.c new file mode 100644 index 0000000..14e0414 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/xtn-combine-1.c @@ -0,0 +1,16 @@ +/* { dg-do assemble } */ +/* { dg-options "-O3 --save-temps --param=vect-epilogues-nomask=0" } */ + +#define SIGN signed +#define TYPE1 char +#define TYPE2 short + +void d2 (SIGN TYPE1 * restrict a, SIGN TYPE2 *b, int n) +{ + for (int i = 0; i < n; i++) + a[i] = b[i]; +} + +/* { dg-final { scan-assembler-times {\tuzp1\t} 1 } } */ +/* { dg-final { scan-assembler-not {\txtn\t} } } */ +/* { dg-final { scan-assembler-not {\txtn2\t} } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/xtn-combine-2.c b/gcc/testsuite/gcc.target/aarch64/xtn-combine-2.c new file mode 100644 index 0000000..c259010 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/xtn-combine-2.c @@ -0,0 +1,16 @@ +/* { dg-do assemble } */ +/* { dg-options "-O3 --save-temps --param=vect-epilogues-nomask=0" } */ + +#define SIGN signed +#define TYPE1 short +#define TYPE2 int + +void d2 (SIGN TYPE1 * restrict a, SIGN TYPE2 *b, int n) +{ + for (int i = 0; i < n; i++) + a[i] = b[i]; +} + +/* { dg-final { scan-assembler-times {\tuzp1\t} 1 } } */ +/* { dg-final { scan-assembler-not {\txtn\t} } } */ +/* { dg-final { scan-assembler-not {\txtn2\t} } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/xtn-combine-3.c b/gcc/testsuite/gcc.target/aarch64/xtn-combine-3.c new file mode 100644 index 0000000..9a2065f --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/xtn-combine-3.c @@ -0,0 +1,16 @@ +/* { dg-do assemble } */ +/* { dg-options "-O3 --save-temps --param=vect-epilogues-nomask=0" } */ + +#define SIGN signed +#define TYPE1 int +#define TYPE2 long long + +void d2 (SIGN TYPE1 * restrict a, SIGN TYPE2 *b, int n) +{ + for (int i = 0; i < n; i++) + a[i] = b[i]; +} + +/* { dg-final { scan-assembler-times {\tuzp1\t} 1 } } */ +/* { dg-final { scan-assembler-not {\txtn\t} } } */ +/* { dg-final { scan-assembler-not {\txtn2\t} } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/xtn-combine-4.c b/gcc/testsuite/gcc.target/aarch64/xtn-combine-4.c new file mode 100644 index 0000000..77c3dce --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/xtn-combine-4.c @@ -0,0 +1,16 @@ +/* { dg-do assemble } */ +/* { dg-options "-O3 --save-temps --param=vect-epilogues-nomask=0" } */ + +#define SIGN unsigned +#define TYPE1 char +#define TYPE2 short + +void d2 (SIGN TYPE1 * restrict a, SIGN TYPE2 *b, int n) +{ + for (int i = 0; i < n; i++) + a[i] = b[i]; +} + +/* { dg-final { scan-assembler-times {\tuzp1\t} 1 } } */ +/* { dg-final { scan-assembler-not {\txtn\t} } } */ +/* { dg-final { scan-assembler-not {\txtn2\t} } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/xtn-combine-5.c b/gcc/testsuite/gcc.target/aarch64/xtn-combine-5.c new file mode 100644 index 0000000..ae30e86 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/xtn-combine-5.c @@ -0,0 +1,16 @@ +/* { dg-do assemble } */ +/* { dg-options "-O3 --save-temps --param=vect-epilogues-nomask=0" } */ + +#define SIGN unsigned +#define TYPE1 short +#define TYPE2 int + +void d2 (SIGN TYPE1 * restrict a, SIGN TYPE2 *b, int n) +{ + for (int i = 0; i < n; i++) + a[i] = b[i]; +} + +/* { dg-final { scan-assembler-times {\tuzp1\t} 1 } } */ +/* { dg-final { scan-assembler-not {\txtn\t} } } */ +/* { dg-final { scan-assembler-not {\txtn2\t} } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/xtn-combine-6.c b/gcc/testsuite/gcc.target/aarch64/xtn-combine-6.c new file mode 100644 index 0000000..882f3d3 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/xtn-combine-6.c @@ -0,0 +1,16 @@ +/* { dg-do assemble } */ +/* { dg-options "-O3 --save-temps --param=vect-epilogues-nomask=0" } */ + +#define SIGN unsigned +#define TYPE1 int +#define TYPE2 long long + +void d2 (SIGN TYPE1 * restrict a, SIGN TYPE2 *b, int n) +{ + for (int i = 0; i < n; i++) + a[i] = b[i]; +} + +/* { dg-final { scan-assembler-times {\tuzp1\t} 1 } } */ +/* { dg-final { scan-assembler-not {\txtn\t} } } */ +/* { dg-final { scan-assembler-not {\txtn2\t} } } */ diff --git a/gcc/testsuite/gcc.target/arm/mve/mve.exp b/gcc/testsuite/gcc.target/arm/mve/mve.exp index d09fc27..a858e52 100644 --- a/gcc/testsuite/gcc.target/arm/mve/mve.exp +++ b/gcc/testsuite/gcc.target/arm/mve/mve.exp @@ -44,6 +44,9 @@ dg-init dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/intrinsics/*.\[cCS\]]] \ "" $DEFAULT_CFLAGS +dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.\[cCS\]]] \ + "" $DEFAULT_CFLAGS + # All done. set dg_runtest_extra_prunes "" dg-finish diff --git a/gcc/testsuite/gcc.target/arm/mve/mve_load_memory_modes.c b/gcc/testsuite/gcc.target/arm/mve/mve_load_memory_modes.c new file mode 100644 index 0000000..e35eb11 --- /dev/null +++ b/gcc/testsuite/gcc.target/arm/mve/mve_load_memory_modes.c @@ -0,0 +1,357 @@ +/* { dg-require-effective-target arm_v8_1m_mve_fp_ok } */ +/* { dg-add-options arm_v8_1m_mve_fp } */ +/* { dg-additional-options "-O2" } */ +/* { dg-final { check-function-bodies "**" "" } } */ + +#include "arm_mve.h" +/* +**off_load8_0: +** ... +** vldrb.8 q0, \[r0, #16\] +** ... +*/ +int8x16_t off_load8_0 (int8_t * a) +{ + return vld1q_s8 (a + 16); +} + +/* +**off_load8_1: +** ... +** vldrb.u16 q0, \[r0, #1\] +** ... +*/ +uint16x8_t off_load8_1 (uint8_t * a) +{ + return vldrbq_u16 (a + 1); +} + +/* +**off_load8_2: +** ... +** vldrb.s32 q0, \[r0, #127\] +** ... +*/ +int32x4_t off_load8_2 (int8_t * a) +{ + return vldrbq_s32 (a + 127); +} + +/* +**off_load8_3: +** ... +** vldrb.8 q0, \[r0, #-127\] +** ... +*/ +uint8x16_t off_load8_3 (uint8_t * a) +{ + return vldrbq_u8 (a - 127); +} + +/* +**not_off_load8_0: +** ... +** vldrb.8 q0, \[r[0-9]+\] +** ... +*/ +int8x16_t not_off_load8_0 (int8_t * a) +{ + return vld1q_s8 (a + 128); +} + +/* +**off_loadfp16_0: +** ... +** vldrh.16 q0, \[r0, #-244\] +** ... +*/ +float16x8_t off_loadfp16_0 (float16_t *a) +{ + return vld1q_f16 (a - 122); +} + +/* +**off_load16_0: +** ... +** vldrh.16 q0, \[r0, #-2\] +** ... +*/ +uint16x8_t off_load16_0 (uint16_t * a) +{ + return vld1q_u16 (a - 1); +} + +/* +**off_load16_1: +** ... +** vldrh.u32 q0, \[r0, #254\] +** ... +*/ +uint32x4_t off_load16_1 (uint16_t * a) +{ + return vldrhq_u32 (a + 127); +} + +/* +**not_off_load16_0: +** ... +** vldrh.16 q0, \[r[0-9]+\] +** ... +*/ +int16x8_t not_off_load16_0 (int8_t * a) +{ + return vld1q_s16 ((int16_t *)(a + 1)); +} + +/* +**not_off_load16_1: +** ... +** vldrh.u32 q0, \[r[0-9]+\] +** ... +*/ +uint32x4_t not_off_load16_1 (uint16_t * a) +{ + return vldrhq_u32 ((a - 128)); +} + +/* +**off_loadfp32_0: +** ... +** vldrw.32 q0, \[r0, #24\] +** ... +*/ +float32x4_t off_loadfp32_0 (float32_t *a) +{ + return vld1q_f32 (a + 6); +} + +/* +**off_load32_0: +** ... +** vldrw.32 q0, \[r0, #4\] +** ... +*/ +uint32x4_t off_load32_0 (uint32_t * a) +{ + return vld1q_u32 (a + 1); +} + +/* +**off_load32_1: +** ... +** vldrw.32 q0, \[r0, #-508\] +** ... +*/ +int32x4_t off_load32_1 (int32_t * a) +{ + return vldrwq_s32 (a - 127); +} +/* +**pre_load8_0: +** ... +** vldrb.8 q[0-9]+, \[r0, #16\]! +** ... +*/ +int8_t* pre_load8_0 (int8_t * a, int8x16_t *v) +{ + a += 16; + *v = vld1q_s8 (a); + return a; +} + +/* +**pre_load8_1: +** ... +** vldrb.u16 q[0-9]+, \[r0, #4\]! +** ... +*/ +uint8_t* pre_load8_1 (uint8_t * a, uint16x8_t *v) +{ + a += 4; + *v = vldrbq_u16 (a); + return a; +} + +/* +**pre_loadfp16_0: +** ... +** vldrh.16 q[0-9]+, \[r0, #128\]! +** ... +*/ +float16_t* pre_loadfp16_0 (float16_t *a, float16x8_t *v) +{ + a += 64; + *v = vld1q_f16 (a); + return a; +} + +/* +**pre_load16_0: +** ... +** vldrh.16 q[0-9]+, \[r0, #-254\]! +** ... +*/ +int16_t* pre_load16_0 (int16_t * a, int16x8_t *v) +{ + a -= 127; + *v = vldrhq_s16 (a); + return a; +} + +/* +**pre_load16_1: +** ... +** vldrh.s32 q[0-9]+, \[r0, #52\]! +** ... +*/ +int16_t* pre_load16_1 (int16_t * a, int32x4_t *v) +{ + a += 26; + *v = vldrhq_s32 (a); + return a; +} + +/* +**pre_loadfp32_0: +** ... +** vldrw.32 q[0-9]+, \[r0, #-72\]! +** ... +*/ +float32_t* pre_loadfp32_0 (float32_t *a, float32x4_t *v) +{ + a -= 18; + *v = vld1q_f32 (a); + return a; +} + + +/* +**pre_load32_0: +** ... +** vldrw.32 q[0-9]+, \[r0, #-4\]! +** ... +*/ +uint32_t* pre_load32_0 (uint32_t * a, uint32x4_t *v) +{ + a -= 1; + *v = vld1q_u32 (a); + return a; +} + + +/* +**post_load8_0: +** ... +** vldrb.8 q[0-9]+, \[r0\], #26 +** ... +*/ +uint8_t* post_load8_0 (uint8_t * a, uint8x16_t *v) +{ + *v = vld1q_u8 (a); + a += 26; + return a; +} + +/* +**post_load8_1: +** ... +** vldrb.s16 q[0-9]+, \[r0\], #-1 +** ... +*/ +int8_t* post_load8_1 (int8_t * a, int16x8_t *v) +{ + *v = vldrbq_s16 (a); + a--; + return a; +} + +/* +**post_load8_2: +** ... +** vldrb.8 q[0-9]+, \[r0\], #26 +** ... +*/ +uint8_t* post_load8_2 (uint8_t * a, uint8x16_t *v) +{ + *v = vld1q_u8 (a); + a += 26; + return a; +} + +/* +**post_load8_3: +** ... +** vldrb.s16 q[0-9]+, \[r0\], #-1 +** ... +*/ +int8_t* post_load8_3 (int8_t * a, int16x8_t *v) +{ + *v = vldrbq_s16 (a); + a--; + return a; +} + +/* +**post_loadfp16_0: +** ... +** vldrh.16 q[0-9]+, \[r0\], #-24 +** ... +*/ +float16_t* post_loadfp16_0 (float16_t *a, float16x8_t *v) +{ + *v = vld1q_f16 (a); + a -= 12; + return a; +} + +/* +**post_load16_0: +** ... +** vldrh.16 q[0-9]+, \[r0\], #-126 +** ... +*/ +uint16_t* post_load16_0 (uint16_t * a, uint16x8_t *v) +{ + *v = vldrhq_u16 (a); + a -= 63; + return a; +} + +/* +**post_load16_1: +** ... +** vldrh.u32 q[0-9]+, \[r0\], #16 +** ... +*/ +uint16_t* post_load16_1 (uint16_t * a, uint32x4_t *v) +{ + *v = vldrhq_u32 (a); + a += 8; + return a; +} + +/* +**post_loadfp32_0: +** ... +** vldrw.32 q[0-9]+, \[r0\], #4 +** ... +*/ +float32_t* post_loadfp32_0 (float32_t *a, float32x4_t *v) +{ + *v = vld1q_f32 (a); + a++; + return a; +} + +/* +**post_load32_0: +** ... +** vldrw.32 q[0-9]+, \[r0\], #-16 +** ... +*/ +int32_t* post_load32_0 (int32_t * a, int32x4_t *v) +{ + *v = vld1q_s32 (a); + a -= 4; + return a; +} diff --git a/gcc/testsuite/gcc.target/arm/mve/mve_store_memory_modes.c b/gcc/testsuite/gcc.target/arm/mve/mve_store_memory_modes.c new file mode 100644 index 0000000..632f5b4 --- /dev/null +++ b/gcc/testsuite/gcc.target/arm/mve/mve_store_memory_modes.c @@ -0,0 +1,370 @@ +/* { dg-require-effective-target arm_v8_1m_mve_fp_ok } */ +/* { dg-add-options arm_v8_1m_mve_fp } */ +/* { dg-additional-options "-O2" } */ +/* { dg-final { check-function-bodies "**" "" } } */ + +#include "arm_mve.h" +/* +**off_store8_0: +** ... +** vstrb.8 q0, \[r0, #16\] +** ... +*/ +uint8_t *off_store8_0 (uint8_t * a, uint8x16_t v) +{ + vst1q_u8 (a + 16, v); + return a; +} + +/* +**off_store8_1: +** ... +** vstrb.16 q0, \[r0, #-1\] +** ... +*/ +int8_t *off_store8_1 (int8_t * a, int16x8_t v) +{ + vstrbq_s16 (a - 1, v); + return a; +} + +/* +**off_store8_2: +** ... +** vstrb.32 q0, \[r0, #-127\] +** ... +*/ +uint8_t *off_store8_2 (uint8_t * a, uint32x4_t v) +{ + vstrbq_u32 (a - 127, v); + return a; +} + +/* +**off_store8_3: +** ... +** vstrb.8 q0, \[r0, #127\] +** ... +*/ +int8_t *off_store8_3 (int8_t * a, int8x16_t v) +{ + vstrbq_s8 (a + 127, v); + return a; +} + +/* +**not_off_store8_0: +** ... +** vstrb.8 q0, \[r[0-9]+\] +** ... +*/ +uint8_t *not_off_store8_0 (uint8_t * a, uint8x16_t v) +{ + vst1q_u8 (a - 128, v); + return a; +} + +/* +**off_storefp16_0: +** ... +** vstrh.16 q0, \[r0, #250\] +** ... +*/ +float16_t *off_storefp16_0 (float16_t *a, float16x8_t v) +{ + vst1q_f16 (a + 125, v); + return a; +} + +/* +**off_store16_0: +** ... +** vstrh.16 q0, \[r0, #4\] +** ... +*/ +int16_t *off_store16_0 (int16_t * a, int16x8_t v) +{ + vst1q_s16 (a + 2, v); + return a; +} + +/* +**off_store16_1: +** ... +** vstrh.32 q0, \[r0, #-254\] +** ... +*/ +int16_t *off_store16_1 (int16_t * a, int32x4_t v) +{ + vstrhq_s32 (a - 127, v); + return a; +} + +/* +**not_off_store16_0: +** ... +** vstrh.16 q0, \[r[0-9]+\] +** ... +*/ +uint8_t *not_off_store16_0 (uint8_t * a, uint16x8_t v) +{ + vst1q_u16 ((uint16_t *)(a - 1), v); + return a; +} + +/* +**not_off_store16_1: +** ... +** vstrh.32 q0, \[r[0-9]+\] +** ... +*/ +int16_t *not_off_store16_1 (int16_t * a, int32x4_t v) +{ + vstrhq_s32 ((a + 128), v); + return a; +} + +/* +**off_storefp32_0: +** ... +** vstrw.32 q0, \[r0, #-412\] +** ... +*/ +float32_t *off_storefp32_0 (float32_t *a, float32x4_t v) +{ + vst1q_f32 (a - 103, v); + return a; +} + +/* +**off_store32_0: +** ... +** vstrw.32 q0, \[r0, #-4\] +** ... +*/ +int32_t *off_store32_0 (int32_t * a, int32x4_t v) +{ + vst1q_s32 (a - 1, v); + return a; +} + +/* +**off_store32_1: +** ... +** vstrw.32 q0, \[r0, #508\] +** ... +*/ +uint32_t *off_store32_1 (uint32_t * a, uint32x4_t v) +{ + vstrwq_u32 (a + 127, v); + return a; +} + +/* +**pre_store8_0: +** ... +** vstrb.8 q[0-9]+, \[r0, #-16\]! +** ... +*/ +uint8_t* pre_store8_0 (uint8_t * a, uint8x16_t v) +{ + a -= 16; + vst1q_u8 (a, v); + return a; +} + +/* +**pre_store8_1: +** ... +** vstrb.16 q[0-9]+, \[r0, #4\]! +** ... +*/ +int8_t* pre_store8_1 (int8_t * a, int16x8_t v) +{ + a += 4; + vstrbq_s16 (a, v); + return a; +} + +/* +**pre_storefp16_0: +** ... +** vstrh.16 q0, \[r0, #8\]! +** ... +*/ +float16_t *pre_storefp16_0 (float16_t *a, float16x8_t v) +{ + a += 4; + vst1q_f16 (a, v); + return a; +} + +/* +**pre_store16_0: +** ... +** vstrh.16 q[0-9]+, \[r0, #254\]! +** ... +*/ +uint16_t* pre_store16_0 (uint16_t * a, uint16x8_t v) +{ + a += 127; + vstrhq_u16 (a, v); + return a; +} + +/* +**pre_store16_1: +** ... +** vstrh.32 q[0-9]+, \[r0, #-52\]! +** ... +*/ +int16_t* pre_store16_1 (int16_t * a, int32x4_t v) +{ + a -= 26; + vstrhq_s32 (a, v); + return a; +} + +/* +**pre_storefp32_0: +** ... +** vstrw.32 q0, \[r0, #-4\]! +** ... +*/ +float32_t *pre_storefp32_0 (float32_t *a, float32x4_t v) +{ + a--; + vst1q_f32 (a, v); + return a; +} + +/* +**pre_store32_0: +** ... +** vstrw.32 q[0-9]+, \[r0, #4\]! +** ... +*/ +int32_t* pre_store32_0 (int32_t * a, int32x4_t v) +{ + a += 1; + vst1q_s32 (a, v); + return a; +} + + +/* +**post_store8_0: +** ... +** vstrb.8 q[0-9]+, \[r0\], #-26 +** ... +*/ +int8_t* post_store8_0 (int8_t * a, int8x16_t v) +{ + vst1q_s8 (a, v); + a -= 26; + return a; +} + +/* +**post_store8_1: +** ... +** vstrb.16 q[0-9]+, \[r0\], #1 +** ... +*/ +uint8_t* post_store8_1 (uint8_t * a, uint16x8_t v) +{ + vstrbq_u16 (a, v); + a++; + return a; +} + +/* +**post_store8_2: +** ... +** vstrb.8 q[0-9]+, \[r0\], #-26 +** ... +*/ +int8_t* post_store8_2 (int8_t * a, int8x16_t v) +{ + vst1q_s8 (a, v); + a -= 26; + return a; +} + +/* +**post_store8_3: +** ... +** vstrb.16 q[0-9]+, \[r0\], #7 +** ... +*/ +uint8_t* post_store8_3 (uint8_t * a, uint16x8_t v) +{ + vstrbq_u16 (a, v); + a += 7; + return a; +} + +/* +**post_storefp16_0: +** ... +** vstrh.16 q[0-9]+, \[r0\], #-16 +** ... +*/ +float16_t *post_storefp16_0 (float16_t *a, float16x8_t v) +{ + vst1q_f16 (a, v); + a -= 8; + return a; +} + +/* +**post_store16_0: +** ... +** vstrh.16 q[0-9]+, \[r0\], #126 +** ... +*/ +int16_t* post_store16_0 (int16_t * a, int16x8_t v) +{ + vstrhq_s16 (a, v); + a += 63; + return a; +} + +/* +**post_store16_1: +** ... +** vstrh.32 q[0-9]+, \[r0\], #-16 +** ... +*/ +uint16_t* post_store16_1 (uint16_t * a, uint32x4_t v) +{ + vstrhq_u32 (a, v); + a -= 8; + return a; +} + +/* +**post_storefp32_0: +** ... +** vstrw.32 q[0-9]+, \[r0\], #-16 +** ... +*/ +float32_t* post_storefp32_0 (float32_t * a, float32x4_t v) +{ + vst1q_f32 (a, v); + a -= 4; + return a; +} + +/* +**post_store32_0: +** ... +** vstrw.32 q[0-9]+, \[r0\], #16 +** ... +*/ +int32_t* post_store32_0 (int32_t * a, int32x4_t v) +{ + vst1q_s32 (a, v); + a += 4; + return a; +} diff --git a/gcc/testsuite/gcc.target/bfin/20090914-3.c b/gcc/testsuite/gcc.target/bfin/20090914-3.c index fb0a9e1..6be5528 100644 --- a/gcc/testsuite/gcc.target/bfin/20090914-3.c +++ b/gcc/testsuite/gcc.target/bfin/20090914-3.c @@ -1,10 +1,11 @@ /* { dg-do compile { target bfin-*-* } } */ typedef long fract32; -main() { +fract32 foo() { fract32 val_tmp; fract32 val1 = 0x7FFFFFFF; fract32 val2 = 0x40000000; val_tmp = __builtin_bfin_mult_fr1x32x32 (0x06666667, val1); val2 = __builtin_bfin_mult_fr1x32x32 (0x79999999, val2); val2 = __builtin_bfin_add_fr1x32 (val_tmp, val2); + return val2; } diff --git a/gcc/testsuite/gcc.target/bfin/ones.c b/gcc/testsuite/gcc.target/bfin/ones.c new file mode 100644 index 0000000..cdffe84 --- /dev/null +++ b/gcc/testsuite/gcc.target/bfin/ones.c @@ -0,0 +1,11 @@ +/* { dg-do compile } */ +/* { dg-options "-O2" } */ + +short foo () +{ + int t = 5; + short r = __builtin_bfin_ones(t); + return r; +} + +/* { dg-final { scan-assembler-not "ONES" } } */ diff --git a/gcc/testsuite/gcc.target/bfin/parity.c b/gcc/testsuite/gcc.target/bfin/parity.c new file mode 100644 index 0000000..6490b7f --- /dev/null +++ b/gcc/testsuite/gcc.target/bfin/parity.c @@ -0,0 +1,9 @@ +/* { dg-do compile } */ +/* { dg-options "-O2" } */ + +int foo(int x) +{ + return __builtin_parity(x); +} + +/* { dg-final { scan-assembler "ONES" } } */ diff --git a/gcc/testsuite/gcc.target/bfin/popcount.c b/gcc/testsuite/gcc.target/bfin/popcount.c new file mode 100644 index 0000000..51c19be --- /dev/null +++ b/gcc/testsuite/gcc.target/bfin/popcount.c @@ -0,0 +1,9 @@ +/* { dg-do compile } */ +/* { dg-options "-O2" } */ + +int foo(int x) +{ + return __builtin_popcount(x); +} + +/* { dg-final { scan-assembler "ONES" } } */ diff --git a/gcc/testsuite/gcc.target/bfin/ssabs.c b/gcc/testsuite/gcc.target/bfin/ssabs.c new file mode 100644 index 0000000..e9d8bae --- /dev/null +++ b/gcc/testsuite/gcc.target/bfin/ssabs.c @@ -0,0 +1,11 @@ +/* { dg-do compile } */ +/* { dg-options "-O2" } */ + +int foo() +{ + int t = -2147483648; + int r = __builtin_bfin_abs_fr1x32(t); + return r; +} + +/* { dg-final { scan-assembler "32767" } } */ diff --git a/gcc/testsuite/gcc.target/bfin/ssashift-1.c b/gcc/testsuite/gcc.target/bfin/ssashift-1.c new file mode 100644 index 0000000..aba90a6 --- /dev/null +++ b/gcc/testsuite/gcc.target/bfin/ssashift-1.c @@ -0,0 +1,52 @@ +/* { dg-do compile } */ +/* { dg-options "-O2" } */ + +int test_ok_pos() +{ + int x = 100; + return __builtin_bfin_shl_fr1x32(x,24); +} + +int test_ok_neg() +{ + int x = -100; + return __builtin_bfin_shl_fr1x32(x,24); +} + +int test_sat_max() +{ + int x = 10000; + return __builtin_bfin_shl_fr1x32(x,24); +} + +int test_sat_min() +{ + int x = -10000; + return __builtin_bfin_shl_fr1x32(x,24); +} + +short stest_ok_pos() +{ + short x = 100; + return __builtin_bfin_shl_fr1x16(x,8); +} + +short stest_ok_neg() +{ + short x = -100; + return __builtin_bfin_shl_fr1x16(x,8); +} + +short stest_sat_max() +{ + short x = 10000; + return __builtin_bfin_shl_fr1x16(x,8); +} + +short stest_sat_min() +{ + short x = -10000; + return __builtin_bfin_shl_fr1x16(x,8); +} +/* { dg-final { scan-assembler-not "\\(S\\)" } } */ +/* { dg-final { scan-assembler-not "\\(V,S\\)" } } */ diff --git a/gcc/testsuite/gcc.target/bfin/ssneg.c b/gcc/testsuite/gcc.target/bfin/ssneg.c new file mode 100644 index 0000000..44ad7ed --- /dev/null +++ b/gcc/testsuite/gcc.target/bfin/ssneg.c @@ -0,0 +1,11 @@ +/* { dg-do compile } */ +/* { dg-options "-O2" } */ + +short foo() +{ + short t = -32768; + short r = __builtin_bfin_negate_fr1x16(t); + return r; +} + +/* { dg-final { scan-assembler "32767" } } */ diff --git a/gcc/testsuite/gcc.target/i386/387-12.c b/gcc/testsuite/gcc.target/i386/387-12.c index 62c1d48..ba86536 100644 --- a/gcc/testsuite/gcc.target/i386/387-12.c +++ b/gcc/testsuite/gcc.target/i386/387-12.c @@ -1,5 +1,5 @@ /* PR target/26915 */ -/* { dg-do compile } */ +/* { dg-do compile { target ia32 } } */ /* { dg-options "-O -mfpmath=387 -mfancy-math-387" } */ double testm0(void) diff --git a/gcc/testsuite/gcc.target/i386/addr-space-2.c b/gcc/testsuite/gcc.target/i386/addr-space-2.c index d5c24b6..9744368 100644 --- a/gcc/testsuite/gcc.target/i386/addr-space-2.c +++ b/gcc/testsuite/gcc.target/i386/addr-space-2.c @@ -1,10 +1,11 @@ /* { dg-do compile } */ -/* { dg-options "-O" } */ +/* { dg-options "-O -Wall" } */ /* { dg-final { scan-assembler "fs:16" } } */ /* { dg-final { scan-assembler "gs:16" } } */ int test(void) { + /* Also verify the accesses don't trigger warnings. */ int __seg_fs *f = (int __seg_fs *)16; int __seg_gs *g = (int __seg_gs *)16; return *f + *g; diff --git a/gcc/testsuite/gcc.target/i386/addr-space-3.c b/gcc/testsuite/gcc.target/i386/addr-space-3.c new file mode 100644 index 0000000..cf0f400 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/addr-space-3.c @@ -0,0 +1,17 @@ +/* PR middle-end/102630 - Spurious -Warray-bounds with named address space + { dg-do compile } + { dg-options "-O -Wall" } + { dg-final { scan-assembler "fs:0" } } + { dg-final { scan-assembler "gs:0" } } */ + +void test_fs_null_store (void) +{ + int __seg_fs *fs = (int __seg_fs *)0; + *fs = 1; +} + +void test_gs_null_store (void) +{ + int __seg_gs *gs = (int __seg_gs *)0; + *gs = 2; +} diff --git a/gcc/testsuite/gcc.target/i386/avx-1.c b/gcc/testsuite/gcc.target/i386/avx-1.c index 8744aa7..154e7b3 100644 --- a/gcc/testsuite/gcc.target/i386/avx-1.c +++ b/gcc/testsuite/gcc.target/i386/avx-1.c @@ -789,9 +789,11 @@ #define __builtin_ia32_vfnmsubsh3_maskz(A, B, C, D, E) __builtin_ia32_vfnmsubsh3_maskz(A, B, C, D, 8) #define __builtin_ia32_vfcmaddcph512_round(A, B, C, D) __builtin_ia32_vfcmaddcph512_round(A, B, C, 8) #define __builtin_ia32_vfcmaddcph512_mask_round(A, C, D, B, E) __builtin_ia32_vfcmaddcph512_mask_round(A, C, D, B, 8) +#define __builtin_ia32_vfcmaddcph512_mask3_round(A, C, D, B, E) __builtin_ia32_vfcmaddcph512_mask3_round(A, C, D, B, 8) #define __builtin_ia32_vfcmaddcph512_maskz_round(B, C, D, A, E) __builtin_ia32_vfcmaddcph512_maskz_round(B, C, D, A, 8) #define __builtin_ia32_vfmaddcph512_round(A, B, C, D) __builtin_ia32_vfmaddcph512_round(A, B, C, 8) #define __builtin_ia32_vfmaddcph512_mask_round(A, C, D, B, E) __builtin_ia32_vfmaddcph512_mask_round(A, C, D, B, 8) +#define __builtin_ia32_vfmaddcph512_mask3_round(A, C, D, B, E) __builtin_ia32_vfmaddcph512_mask3_round(A, C, D, B, 8) #define __builtin_ia32_vfmaddcph512_maskz_round(B, C, D, A, E) __builtin_ia32_vfmaddcph512_maskz_round(B, C, D, A, 8) #define __builtin_ia32_vfmulcph512_round(A, B, C) __builtin_ia32_vfmulcph512_round(A, B, 8) #define __builtin_ia32_vfmulcph512_mask_round(A, C, D, B, E) __builtin_ia32_vfmulcph512_mask_round(A, C, D, B, 8) @@ -799,9 +801,11 @@ #define __builtin_ia32_vfcmulcph512_mask_round(A, C, D, B, E) __builtin_ia32_vfcmulcph512_mask_round(A, C, D, B, 8) #define __builtin_ia32_vfmaddcsh_round(A, B, C, D) __builtin_ia32_vfmaddcsh_round(A, B, C, 8) #define __builtin_ia32_vfmaddcsh_mask_round(A, C, D, B, E) __builtin_ia32_vfmaddcsh_mask_round(A, C, D, B, 8) +#define __builtin_ia32_vfmaddcsh_mask3_round(A, C, D, B, E) __builtin_ia32_vfmaddcsh_mask3_round(A, C, D, B, 8) #define __builtin_ia32_vfmaddcsh_maskz_round(B, C, D, A, E) __builtin_ia32_vfmaddcsh_maskz_round(B, C, D, A, 8) #define __builtin_ia32_vfcmaddcsh_round(A, B, C, D) __builtin_ia32_vfcmaddcsh_round(A, B, C, 8) #define __builtin_ia32_vfcmaddcsh_mask_round(A, C, D, B, E) __builtin_ia32_vfcmaddcsh_mask_round(A, C, D, B, 8) +#define __builtin_ia32_vfcmaddcsh_mask3_round(A, C, D, B, E) __builtin_ia32_vfcmaddcsh_mask3_round(A, C, D, B, 8) #define __builtin_ia32_vfcmaddcsh_maskz_round(B, C, D, A, E) __builtin_ia32_vfcmaddcsh_maskz_round(B, C, D, A, 8) #define __builtin_ia32_vfmulcsh_round(A, B, C) __builtin_ia32_vfmulcsh_round(A, B, 8) #define __builtin_ia32_vfmulcsh_mask_round(A, C, D, B, E) __builtin_ia32_vfmulcsh_mask_round(A, C, D, B, 8) diff --git a/gcc/testsuite/gcc.target/i386/avx2-vect-mask-store-move1.c b/gcc/testsuite/gcc.target/i386/avx2-vect-mask-store-move1.c index 989ba40..6a47a09 100644 --- a/gcc/testsuite/gcc.target/i386/avx2-vect-mask-store-move1.c +++ b/gcc/testsuite/gcc.target/i386/avx2-vect-mask-store-move1.c @@ -78,4 +78,4 @@ avx2_test (void) abort (); } -/* { dg-final { scan-tree-dump-times "Move stmt to created bb" 6 "vect" } } */ +/* { dg-final { scan-tree-dump-times "Move stmt to created bb" 10 "vect" } } */ diff --git a/gcc/testsuite/gcc.target/i386/avx512f-pr96891-3.c b/gcc/testsuite/gcc.target/i386/avx512f-pr96891-3.c index 1cf18f2..06db752 100644 --- a/gcc/testsuite/gcc.target/i386/avx512f-pr96891-3.c +++ b/gcc/testsuite/gcc.target/i386/avx512f-pr96891-3.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-mavx512vl -mavx512bw -mavx512dq -O2 -masm=att" } */ +/* { dg-options "-mavx512vl -mavx512bw -mavx512dq -O2 -masm=att -mstv -mno-stackrealign" } */ /* { dg-final { scan-assembler-not {not[bwlqd]\]} } } */ /* { dg-final { scan-assembler-times {(?n)vpcmp[bwdq][ \t]*\$5} 4} } */ /* { dg-final { scan-assembler-times {(?n)vpcmp[bwdq][ \t]*\$6} 4} } */ diff --git a/gcc/testsuite/gcc.target/i386/avx512fp16-13.c b/gcc/testsuite/gcc.target/i386/avx512fp16-13.c index c3bae65..b73a8f4 100644 --- a/gcc/testsuite/gcc.target/i386/avx512fp16-13.c +++ b/gcc/testsuite/gcc.target/i386/avx512fp16-13.c @@ -18,7 +18,7 @@ store256_ph (void *p, __m256h a) _mm256_store_ph (p, a); } -/* { dg-final { scan-assembler-times "vmovdqa64\[ \\t\]+\[^\{\n\]*%ymm\[0-9\]+\[^\n\]*\\)" 1 } } */ +/* { dg-final { scan-assembler-times "vmovdqa\[ \\t\]+\[^\{\n\]*%ymm\[0-9\]+\[^\n\]*\\)" 1 } } */ void __attribute__ ((noinline, noclone)) @@ -27,7 +27,7 @@ store_ph (void *p, __m128h a) _mm_store_ph (p, a); } -/* { dg-final { scan-assembler-times "vmovdqa64\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+\[^\n\]*\\)" 1 } } */ +/* { dg-final { scan-assembler-times "vmovdqa\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+\[^\n\]*\\)" 1 } } */ __m512h __attribute__ ((noinline, noclone)) @@ -45,7 +45,7 @@ load256_ph (void const *p) return _mm256_load_ph (p); } -/* { dg-final { scan-assembler-times "vmovdqa64\[ \\t\]+\[^\{\n\]*%ymm\[0-9\]+\[^\n\]*\\)" 1 } } */ +/* { dg-final { scan-assembler-times "vmovdqa\[ \\t\]+\[^\{\n\]*%ymm\[0-9\]+\[^\n\]*\\)" 1 } } */ __m128h __attribute__ ((noinline, noclone)) @@ -53,7 +53,7 @@ load_ph (void const *p) { return _mm_load_ph (p); } -/* { dg-final { scan-assembler-times "vmovdqa64\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+\[^\n\]*\\)" 1 } } */ +/* { dg-final { scan-assembler-times "vmovdqa\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+\[^\n\]*\\)" 1 } } */ __m512h __attribute__ ((noinline, noclone)) diff --git a/gcc/testsuite/gcc.target/i386/avx512fp16-builtin_shuffle-1.c b/gcc/testsuite/gcc.target/i386/avx512fp16-builtin_shuffle-1.c new file mode 100644 index 0000000..89d3567 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/avx512fp16-builtin_shuffle-1.c @@ -0,0 +1,86 @@ +/* { dg-do compile } */ +/* { dg-options "-mavx512fp16 -mavx512vl -O2" } */ +/* { dg-final { scan-assembler-not "movw" } } */ +/* { dg-final { scan-assembler-times "vpermi2w" 3 } } */ +/* { dg-final { scan-assembler-times "vpermw" 6 } } */ +/* { dg-final { scan-assembler-times "vpshufb" 3 } } */ +/* { dg-final { scan-assembler-times "vpermt2w" 6 } } */ + +typedef _Float16 v32hf __attribute__((vector_size (64))); +typedef _Float16 v16hf __attribute__((vector_size (32))); +typedef _Float16 v8hf __attribute__((vector_size (16))); +typedef short v32hi __attribute__((vector_size (64))); +typedef short v16hi __attribute__((vector_size (32))); +typedef short v8hi __attribute__((vector_size (16))); + +#define PERM_CONST_RANDOM_v32hi \ +{ 0, 21, 15, 9, 43, 25, 37, 48, \ + 8, 16, 27, 51, 30, 12, 6, 46, \ + 34, 3, 11, 5, 17, 53, 26, 39, \ + 2, 18, 40, 61, 19, 4, 50, 29 } + +#define PERM_CONST_RANDOM_RANGE32_v32hi \ +{ 0, 21, 10, 23, 8, 18, 7, 19, \ + 4, 25, 3, 31, 5, 22, 11, 17, \ + 9, 20, 2, 24, 1, 30, 12, 27, \ + 13, 28, 6, 29, 14, 16, 15, 23 } + +#define PERM_CONST_RANDOM_v16hi \ +{ 0, 21, 15, 9, 13, 25, 30, 18, \ + 8, 16, 17, 11, 4, 22, 6, 7 } + +#define PERM_CONST_RANDOM_RANGE16_v16hi \ +{ 0, 9, 1, 12, 4, 15, 7, 13, \ + 3, 10, 6, 14, 5, 8, 2, 11 } + +#define PERM_CONST_RANDOM_v8hi \ +{ 0, 14, 15, 9, 13, 2, 3, 5 } + +#define PERM_CONST_RANDOM_RANGE8_v8hi \ +{ 0, 7, 2, 5, 3, 4, 1, 6 } + +#define PERM_CONST_RANDOM(size) \ + PERM_CONST_RANDOM_v##size##hi + +#define PERM_CONST_RANDOM_RANGE(size) \ + PERM_CONST_RANDOM_RANGE##size##_v##size##hi + +#define SHUFFLE_CONST_RANDOM(type, itype, size) \ +type foo_##type##shuffle_2param_const_random (type a, type b) \ +{ \ + return __builtin_shuffle (a, b, \ + (itype) PERM_CONST_RANDOM (size)); \ +} \ +type foo_##type##shuffle_2param_const_random_range (type a, type b) \ +{ \ + return __builtin_shuffle (a, b, \ + (itype) PERM_CONST_RANDOM_RANGE (size)); \ +} \ +type foo_##type##shuffle_1param_const_random (type a) \ +{ \ + return __builtin_shuffle (a, \ + (itype) PERM_CONST_RANDOM (size)); \ +} \ +type foo_##type##shuffle_1param_const_random_range (type a) \ +{ \ + return __builtin_shuffle (a, \ + (itype) PERM_CONST_RANDOM_RANGE (size)); \ +} + +#define SHUFFLE_VEC_INDEX(type, itype) \ +type foo##type##itype##shuffle_2param_vec (type a, type b, itype c) \ +{ \ + return __builtin_shuffle (a, b, c); \ +} \ +type foo##type##itype##shuffle_1param_vec (type a, itype c) \ +{ \ + return __builtin_shuffle (a, c); \ +} + +SHUFFLE_CONST_RANDOM (v32hf, v32hi, 32) +SHUFFLE_CONST_RANDOM (v16hf, v16hi, 16) +SHUFFLE_CONST_RANDOM (v8hf, v8hi, 8) + +SHUFFLE_VEC_INDEX (v32hf, v32hi) +SHUFFLE_VEC_INDEX (v16hf, v16hi) +SHUFFLE_VEC_INDEX (v8hf, v8hi) diff --git a/gcc/testsuite/gcc.target/i386/avx512fp16-complex-fma.c b/gcc/testsuite/gcc.target/i386/avx512fp16-complex-fma.c new file mode 100644 index 0000000..2dfd369 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/avx512fp16-complex-fma.c @@ -0,0 +1,18 @@ +/* { dg-do compile } */ +/* { dg-options "-mavx512fp16 -O2 -Ofast" } */ +/* { dg-final { scan-assembler-times "vfmaddcph\[ \\t\]+\[^\{\n\]*%zmm\[0-9\]+\[^\n\r]*%zmm\[0-9\]+\[^\n\r]*%zmm\[0-9\]+(?:\n|\[ \\t\]+#)" 2 } } */ +/* { dg-final { scan-assembler-not "vaddph\[ \\t\]+\[^\{\n\]*%zmm\[0-9\]+\[^\n\r]*%zmm\[0-9\]+\[^\n\r]*%zmm\[0-9\]+(?:\n|\[ \\t\]+#)"} } */ +/* { dg-final { scan-assembler-not "vfmulcph\[ \\t\]+\[^\{\n\]*%zmm\[0-9\]+\[^\n\r]*%zmm\[0-9\]+\[^\n\r]*%zmm\[0-9\]+(?:\n|\[ \\t\]+#)"} } */ +/* { dg-final { scan-assembler-times "vfcmaddcph\[ \\t\]+\[^\{\n\]*%zmm\[0-9\]+\[^\n\r]*%zmm\[0-9\]+\[^\n\r]*%zmm\[0-9\]+(?:\n|\[ \\t\]+#)" 2 } } */ + +#include <immintrin.h> +volatile __m512h x1, x2, res, a, b; +void extern +avx512f_test (void) +{ + res = _mm512_add_ph (x1, _mm512_fmadd_pch (a, b, _mm512_setzero_ph())); + res = _mm512_add_ph (x1, _mm512_fcmadd_pch (a, b, _mm512_setzero_ph())); + + res = _mm512_add_ph (x1, _mm512_fmul_pch (a, b)); + res = _mm512_add_ph (x1, _mm512_fcmul_pch (a, b)); +} diff --git a/gcc/testsuite/gcc.target/i386/avx512fp16-pr101846.c b/gcc/testsuite/gcc.target/i386/avx512fp16-pr101846.c new file mode 100644 index 0000000..abd9156 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/avx512fp16-pr101846.c @@ -0,0 +1,56 @@ +/* { dg-do compile } */ +/* { dg-options "-mavx512fp16 -mavx512vl -O2" } */ +/* { dg-final { scan-assembler-times "vpmovzxwd" "3" } } */ +/* { dg-final { scan-assembler-times "vpmovdw" "3" } } */ + +typedef _Float16 v32hf __attribute__((vector_size (64))); +typedef _Float16 v16hf __attribute__((vector_size (32))); +typedef _Float16 v8hf __attribute__((vector_size (16))); +typedef _Float16 v4hf __attribute__((vector_size (8))); +typedef short v4hi __attribute__((vector_size (8))); +typedef short v8hi __attribute__((vector_size (16))); + +#define PERM_CONST_INTERLEAVE_v32hi \ +0, 16, 1, 17, 2, 18, 3, 19, \ +4, 20, 5, 21, 6, 22, 7, 23, \ +8, 24, 9, 25, 10, 26, 11, 27, \ +12, 28, 13, 29, 14, 30, 15, 31 + +#define PERM_CONST_INTERLEAVE_v16hi \ +0, 8, 1, 9, 2, 10, 3, 11, \ +4, 12, 5, 13, 6, 14, 7, 15 + +#define PERM_CONST_INTERLEAVE_v8hi \ +0, 4, 1, 5, 2, 6, 3, 7 + +#define PERM_CONST_TRUNCATE_v32hi \ +0, 2, 4, 6, 8, 10, 12, 14, \ +16, 18, 20, 22, 24, 26, 28, 30 + +#define PERM_CONST_TRUNCATE_v16hi \ +0, 2, 4, 6, 8, 10, 12, 14 + +#define PERM_CONST_TRUNCATE_v8hi \ +0, 2, 4, 6 + +#define PERM_CONST_INTERLEAVE(size) \ + PERM_CONST_INTERLEAVE_v##size##hi + +#define PERM_CONST_TRUNCATE(size) \ + PERM_CONST_TRUNCATE_v##size##hi + +#define SHUFFLE_CONST_INTERLEAVE(type, rtype, size) \ +rtype foo_##type##shufflevector_const_interleave (type a) \ +{ \ + return __builtin_shufflevector (a, (type) {}, \ + PERM_CONST_INTERLEAVE (size)); \ +} \ +type foo_##type##shufflevector_const_trunc (rtype a) \ +{ \ + return __builtin_shufflevector (a, a, \ + PERM_CONST_TRUNCATE (size)); \ +} + +SHUFFLE_CONST_INTERLEAVE (v16hf, v32hf, 32) +SHUFFLE_CONST_INTERLEAVE (v8hf, v16hf, 16) +SHUFFLE_CONST_INTERLEAVE (v4hf, v8hf, 8) diff --git a/gcc/testsuite/gcc.target/i386/avx512fp16-pr94680.c b/gcc/testsuite/gcc.target/i386/avx512fp16-pr94680.c new file mode 100644 index 0000000..bfe1123 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/avx512fp16-pr94680.c @@ -0,0 +1,61 @@ +/* { dg-do compile } */ +/* { dg-options "-mavx512fp16 -mavx512vl -O2" } */ +/* { dg-final { scan-assembler-times "vmovdqa" 4 } } */ +/* { dg-final { scan-assembler-times "vmovq" 2 } } */ + +typedef _Float16 v32hf __attribute__((vector_size (64))); +typedef _Float16 v16hf __attribute__((vector_size (32))); +typedef _Float16 v8hf __attribute__((vector_size (16))); +typedef short v32hi __attribute__((vector_size (64))); +typedef short v16hi __attribute__((vector_size (32))); +typedef short v8hi __attribute__((vector_size (16))); + + +#define PERM_CONST_CONCAT0_v32hi \ +{ 0, 1, 2, 3, 4, 5, 6, 7, \ + 8, 9, 10, 11, 12, 13, 14, 15, \ + 34, 53, 41, 55, 57, 43, 36, 39, \ + 62, 48, 50, 51, 49, 44, 60, 37 } + +#define PERM_CONST_CONCAT0_v32hi_l \ +{ 32, 33, 34, 35, 36, 37, 38, 39, \ + 40, 41, 42, 43, 44, 45, 46, 47, \ + 31, 0, 29, 2, 27, 4, 25, 6, 23, \ + 8, 21, 10, 19, 12, 17, 14 } + +#define PERM_CONST_CONCAT0_v16hi \ +{ 0, 1, 2, 3, 4, 5, 6, 7, \ + 21, 26, 17, 31, 24, 22, 30, 19 } + +#define PERM_CONST_CONCAT0_v16hi_l \ +{ 16, 17, 18, 19, 20, 21, 22, 23, \ + 15, 0, 13, 2, 11, 4, 9, 6 } + +#define PERM_CONST_CONCAT0_v8hi \ +{ 0, 1, 2, 3, 9, 11, 14, 12 } + +#define PERM_CONST_CONCAT0_v8hi_l \ +{ 8, 9, 10, 11, 3, 5, 1, 7 } + +#define PERM_CONST_CONCAT0(type) \ + PERM_CONST_CONCAT0_##type + +#define PERM_CONST_CONCAT0_L(type) \ + PERM_CONST_CONCAT0_##type##_l + +#define SHUFFLE_CONST_CONCAT0(type, itype) \ +type foo_##type##shuffle_const_concat0 (type a) \ +{ \ + return __builtin_shuffle (a, (type) {0}, \ + (itype) PERM_CONST_CONCAT0 (itype)); \ +} \ +type foo_##type##shuffle_const_concat0_l (type a) \ +{ \ + return __builtin_shuffle ((type) {0}, a, \ + (itype) PERM_CONST_CONCAT0_L (itype)); \ +} + +SHUFFLE_CONST_CONCAT0 (v32hf, v32hi) +SHUFFLE_CONST_CONCAT0 (v16hf, v16hi) +SHUFFLE_CONST_CONCAT0 (v8hf, v8hi) + diff --git a/gcc/testsuite/gcc.target/i386/avx512fp16-set1-pch-1a.c b/gcc/testsuite/gcc.target/i386/avx512fp16-set1-pch-1a.c new file mode 100644 index 0000000..0055193 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/avx512fp16-set1-pch-1a.c @@ -0,0 +1,13 @@ +/* { dg-do compile} */ +/* { dg-options "-O2 -mavx512fp16" } */ + +#include <immintrin.h> + +__m512h +__attribute__ ((noinline, noclone)) +test_mm512_set1_pch (_Float16 _Complex A) +{ + return _mm512_set1_pch(A); +} + +/* { dg-final { scan-assembler "vbroadcastss\[ \\t\]+\[^\n\r\]*%zmm\[01\]" } } */ diff --git a/gcc/testsuite/gcc.target/i386/avx512fp16-set1-pch-1b.c b/gcc/testsuite/gcc.target/i386/avx512fp16-set1-pch-1b.c new file mode 100644 index 0000000..450d7e3 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/avx512fp16-set1-pch-1b.c @@ -0,0 +1,42 @@ +/* { dg-do run { target avx512fp16 } } */ +/* { dg-options "-O2 -mavx512fp16" } */ + +#include<stdio.h> +#include <math.h> +#include <complex.h> + +static void do_test (void); + +#define DO_TEST do_test +#define AVX512FP16 + +#include <immintrin.h> +#include "avx512-check.h" + +static void +do_test (void) +{ + _Float16 _Complex fc = 1.0 + 1.0*I; + union + { + _Float16 _Complex a; + float b; + } u = { .a = fc }; + float ff= u.b; + + typedef union + { + float fp[16]; + __m512h m512h; + } u1; + + __m512h test512 = _mm512_set1_pch(fc); + + u1 test; + test.m512h = test512; + for (int i = 0; i<16; i++) + { + if (test.fp[i] != ff) abort(); + } + +} diff --git a/gcc/testsuite/gcc.target/i386/avx512fp16-trunchf.c b/gcc/testsuite/gcc.target/i386/avx512fp16-trunchf.c index 2c025b7..337a7b0 100644 --- a/gcc/testsuite/gcc.target/i386/avx512fp16-trunchf.c +++ b/gcc/testsuite/gcc.target/i386/avx512fp16-trunchf.c @@ -1,7 +1,7 @@ /* { dg-do compile } */ /* { dg-options "-O2 -mavx512fp16" } */ -/* { dg-final { scan-assembler-times "vcvttsh2si\[ \\t\]+\[^\{\n\]*(?:%xmm\[0-9\]|\\(%esp\\))+, %eax(?:\n|\[ \\t\]+#)" 3 } } */ -/* { dg-final { scan-assembler-times "vcvttsh2usi\[ \\t\]+\[^\{\n\]*(?:%xmm\[0-9\]|\\(%esp\\))+, %eax(?:\n|\[ \\t\]+#)" 2 } } */ +/* { dg-final { scan-assembler-times "vcvttsh2si\[ \\t\]+\[^\{\n\]*(?:%xmm\[0-9\]|\\(%e\[bs\]p\\))+, %eax(?:\n|\[ \\t\]+#)" 3 } } */ +/* { dg-final { scan-assembler-times "vcvttsh2usi\[ \\t\]+\[^\{\n\]*(?:%xmm\[0-9\]|\\(%e\[bs\]p\\))+, %eax(?:\n|\[ \\t\]+#)" 2 } } */ /* { dg-final { scan-assembler-times "vcvttsh2si\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+, %rax(?:\n|\[ \\t\]+#)" 1 { target { ! ia32 } } } } */ /* { dg-final { scan-assembler-times "vcvttsh2usi\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+, %rax(?:\n|\[ \\t\]+#)" 1 { target { ! ia32 } } } } */ /* { dg-final { scan-assembler "xorl\[ \\t\]+%edx, %edx" { target ia32 } } } */ diff --git a/gcc/testsuite/gcc.target/i386/avx512fp16-v4hf-concat.c b/gcc/testsuite/gcc.target/i386/avx512fp16-v4hf-concat.c new file mode 100644 index 0000000..3b8a7f3 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/avx512fp16-v4hf-concat.c @@ -0,0 +1,16 @@ +/* { dg-do compile } */ +/* { dg-options "-mavx512fp16 -O2" } */ +/* { dg-final { scan-assembler-times "vpunpcklqdq" 1 } } */ + +typedef _Float16 v8hf __attribute__((vector_size (16))); +typedef _Float16 v4hf __attribute__((vector_size (8))); + +v8hf foov (v4hf a, v4hf b) +{ + return __builtin_shufflevector (a, b, 0, 1, 2, 3, 4, 5, 6, 7); +} + +v8hf foov2 (v4hf a) +{ + return __builtin_shufflevector (a, (v4hf){0}, 0, 1, 2, 3, 4, 5, 6, 7); +} diff --git a/gcc/testsuite/gcc.target/i386/avx512fp16-vfcmaddcph-1a.c b/gcc/testsuite/gcc.target/i386/avx512fp16-vfcmaddcph-1a.c index 6c2c34c..cd39b7f 100644 --- a/gcc/testsuite/gcc.target/i386/avx512fp16-vfcmaddcph-1a.c +++ b/gcc/testsuite/gcc.target/i386/avx512fp16-vfcmaddcph-1a.c @@ -6,6 +6,7 @@ /* { dg-final { scan-assembler-times "vfcmaddcph\[ \\t\]+\{rn-sae\}\[^\{\n\]*%zmm\[0-9\]+\[^\n\r]*%zmm\[0-9\]+\[^\n\r]*%zmm\[0-9\]+(?:\n|\[ \\t\]+#)" 1 } } */ /* { dg-final { scan-assembler-times "vfcmaddcph\[ \\t\]+\{rn-sae\}\[^\{\n\]*%zmm\[0-9\]+\[^\n\r]*%zmm\[0-9\]+\[^\n\r]*%zmm\[0-9\]+\{%k\[0-9\]\}\[^\n\r]*(?:\n|\[ \\t\]+#)" 2 } } */ /* { dg-final { scan-assembler-times "vfcmaddcph\[ \\t\]+\{rz-sae\}\[^\{\n\]*%zmm\[0-9\]+\[^\n\r]*%zmm\[0-9\]+\[^\n\r]*%zmm\[0-9\]+\{%k\[0-9\]\}\{z\}\[^\n\r]*(?:\n|\[ \\t\]+#)" 1 } } */ +/* { dg-final { scan-assembler-times "vblendmps\[ \\t\]+%zmm\[0-9\]+\[^\n\r]*%zmm\[0-9\]+\[^\n\r]*%zmm\[0-9\]+\{%k\[0-9\]\}(?:\n|\[ \\t\]+#)" 2 } } */ #include <immintrin.h> diff --git a/gcc/testsuite/gcc.target/i386/avx512fp16-vfcmaddcsh-1a.c b/gcc/testsuite/gcc.target/i386/avx512fp16-vfcmaddcsh-1a.c index 8bd8eeb..eb96588 100644 --- a/gcc/testsuite/gcc.target/i386/avx512fp16-vfcmaddcsh-1a.c +++ b/gcc/testsuite/gcc.target/i386/avx512fp16-vfcmaddcsh-1a.c @@ -1,11 +1,13 @@ /* { dg-do compile } */ -/* { dg-options "-mavx512fp16 -O2" } */ +/* { dg-options "-mavx512fp16 -mno-avx512vl -O2" } */ /* { dg-final { scan-assembler-times "vfcmaddcsh\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+(?:\n|\[ \\t\]+#)" 1 } } */ /* { dg-final { scan-assembler-times "vfcmaddcsh\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\{%k\[0-9\]\}\[^\{\n\r]*(?:\n|\[ \\t\]+#)" 2 } } */ /* { dg-final { scan-assembler-times "vfcmaddcsh\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\{%k\[0-9\]\}\{z\}\[^\n\r]*(?:\n|\[ \\t\]+#)" 1 } } */ /* { dg-final { scan-assembler-times "vfcmaddcsh\[ \\t\]+\{rn-sae\}\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+(?:\n|\[ \\t\]+#)" 1 } } */ /* { dg-final { scan-assembler-times "vfcmaddcsh\[ \\t\]+\{rn-sae\}\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\{%k\[0-9\]\}\[^\n\r]*(?:\n|\[ \\t\]+#)" 2 } } */ /* { dg-final { scan-assembler-times "vfcmaddcsh\[ \\t\]+\{rz-sae\}\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\{%k\[0-9\]\}\{z\}\[^\n\r]*(?:\n|\[ \\t\]+#)" 1 } } */ +/* { dg-final { scan-assembler-times "vblendvps\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+(?:\n|\[ \\t\]+#)" 2 } } */ +/* { dg-final { scan-assembler-times "vmovss\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+(?:\n|\[ \\t\]+#)" 2 } } */ #include <immintrin.h> diff --git a/gcc/testsuite/gcc.target/i386/avx512fp16-vfcmaddcsh-1c.c b/gcc/testsuite/gcc.target/i386/avx512fp16-vfcmaddcsh-1c.c new file mode 100644 index 0000000..79a295f --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/avx512fp16-vfcmaddcsh-1c.c @@ -0,0 +1,13 @@ +/* { dg-do compile } */ +/* { dg-options "-mavx512fp16 -mavx512vl -O2" } */ +/* { dg-final { scan-assembler-times "vfcmaddcsh\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+(?:\n|\[ \\t\]+#)" 1 } } */ +/* { dg-final { scan-assembler-times "vfcmaddcsh\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\{%k\[0-9\]\}\[^\{\n\r]*(?:\n|\[ \\t\]+#)" 2 } } */ +/* { dg-final { scan-assembler-times "vfcmaddcsh\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\{%k\[0-9\]\}\{z\}\[^\n\r]*(?:\n|\[ \\t\]+#)" 1 } } */ +/* { dg-final { scan-assembler-times "vfcmaddcsh\[ \\t\]+\{rn-sae\}\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+(?:\n|\[ \\t\]+#)" 1 } } */ +/* { dg-final { scan-assembler-times "vfcmaddcsh\[ \\t\]+\{rn-sae\}\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\{%k\[0-9\]\}\[^\n\r]*(?:\n|\[ \\t\]+#)" 2 } } */ +/* { dg-final { scan-assembler-times "vfcmaddcsh\[ \\t\]+\{rz-sae\}\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\{%k\[0-9\]\}\{z\}\[^\n\r]*(?:\n|\[ \\t\]+#)" 1 } } */ +/* { dg-final { scan-assembler-times "vblendmps\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\{%k\[0-9\]\}\[^\{\n\r]*(?:\n|\[ \\t\]+#)" 2 } } */ +/* { dg-final { scan-assembler-times "vmovss\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+(?:\n|\[ \\t\]+#)" 2 } } */ + +#include "avx512fp16-vfcmaddcsh-1a.c" + diff --git a/gcc/testsuite/gcc.target/i386/avx512fp16-vfmaddcph-1a.c b/gcc/testsuite/gcc.target/i386/avx512fp16-vfmaddcph-1a.c index 4dae5f0..859b215 100644 --- a/gcc/testsuite/gcc.target/i386/avx512fp16-vfmaddcph-1a.c +++ b/gcc/testsuite/gcc.target/i386/avx512fp16-vfmaddcph-1a.c @@ -6,6 +6,7 @@ /* { dg-final { scan-assembler-times "vfmaddcph\[ \\t\]+\{rn-sae\}\[^\{\n\]*%zmm\[0-9\]+\[^\n\r]*%zmm\[0-9\]+\[^\n\r]*%zmm\[0-9\]+(?:\n|\[ \\t\]+#)" 1 } } */ /* { dg-final { scan-assembler-times "vfmaddcph\[ \\t\]+\{rn-sae\}\[^\{\n\]*%zmm\[0-9\]+\[^\n\r]*%zmm\[0-9\]+\[^\n\r]*%zmm\[0-9\]+\{%k\[0-9\]\}\[^\n\r]*(?:\n|\[ \\t\]+#)" 2 } } */ /* { dg-final { scan-assembler-times "vfmaddcph\[ \\t\]+\{rz-sae\}\[^\{\n\]*%zmm\[0-9\]+\[^\n\r]*%zmm\[0-9\]+\[^\n\r]*%zmm\[0-9\]+\{%k\[0-9\]\}\{z\}\[^\n\r]*(?:\n|\[ \\t\]+#)" 1 } } */ +/* { dg-final { scan-assembler-times "vblendmps\[ \\t\]+%zmm\[0-9\]+\[^\n\r]*%zmm\[0-9\]+\[^\n\r]*%zmm\[0-9\]+\{%k\[0-9\]\}(?:\n|\[ \\t\]+#)" 2 } } */ #include <immintrin.h> diff --git a/gcc/testsuite/gcc.target/i386/avx512fp16-vfmaddcsh-1a.c b/gcc/testsuite/gcc.target/i386/avx512fp16-vfmaddcsh-1a.c index 1e376b4..288d1c1 100644 --- a/gcc/testsuite/gcc.target/i386/avx512fp16-vfmaddcsh-1a.c +++ b/gcc/testsuite/gcc.target/i386/avx512fp16-vfmaddcsh-1a.c @@ -1,11 +1,13 @@ /* { dg-do compile } */ -/* { dg-options "-mavx512fp16 -O2" } */ +/* { dg-options "-mavx512fp16 -mno-avx512vl -O2" } */ /* { dg-final { scan-assembler-times "vfmaddcsh\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+(?:\n|\[ \\t\]+#)" 1 } } */ /* { dg-final { scan-assembler-times "vfmaddcsh\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\{%k\[0-9\]\}\[^\{\n\r]*(?:\n|\[ \\t\]+#)" 2 } } */ /* { dg-final { scan-assembler-times "vfmaddcsh\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\{%k\[0-9\]\}\{z\}\[^\n\r]*(?:\n|\[ \\t\]+#)" 1 } } */ /* { dg-final { scan-assembler-times "vfmaddcsh\[ \\t\]+\{rn-sae\}\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+(?:\n|\[ \\t\]+#)" 1 } } */ /* { dg-final { scan-assembler-times "vfmaddcsh\[ \\t\]+\{rn-sae\}\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\{%k\[0-9\]\}\[^\n\r]*(?:\n|\[ \\t\]+#)" 2 } } */ /* { dg-final { scan-assembler-times "vfmaddcsh\[ \\t\]+\{rz-sae\}\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\{%k\[0-9\]\}\{z\}\[^\n\r]*(?:\n|\[ \\t\]+#)" 1 } } */ +/* { dg-final { scan-assembler-times "vblendvps\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+(?:\n|\[ \\t\]+#)" 2 } } */ +/* { dg-final { scan-assembler-times "vmovss\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+(?:\n|\[ \\t\]+#)" 2 } } */ #include <immintrin.h> diff --git a/gcc/testsuite/gcc.target/i386/avx512fp16-vfmaddcsh-1c.c b/gcc/testsuite/gcc.target/i386/avx512fp16-vfmaddcsh-1c.c new file mode 100644 index 0000000..7863f8f --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/avx512fp16-vfmaddcsh-1c.c @@ -0,0 +1,13 @@ +/* { dg-do compile } */ +/* { dg-options "-mavx512fp16 -mavx512vl -O2" } */ +/* { dg-final { scan-assembler-times "vfmaddcsh\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+(?:\n|\[ \\t\]+#)" 1 } } */ +/* { dg-final { scan-assembler-times "vfmaddcsh\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\{%k\[0-9\]\}\[^\{\n\r]*(?:\n|\[ \\t\]+#)" 2 } } */ +/* { dg-final { scan-assembler-times "vfmaddcsh\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\{%k\[0-9\]\}\{z\}\[^\n\r]*(?:\n|\[ \\t\]+#)" 1 } } */ +/* { dg-final { scan-assembler-times "vfmaddcsh\[ \\t\]+\{rn-sae\}\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+(?:\n|\[ \\t\]+#)" 1 } } */ +/* { dg-final { scan-assembler-times "vfmaddcsh\[ \\t\]+\{rn-sae\}\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\{%k\[0-9\]\}\[^\n\r]*(?:\n|\[ \\t\]+#)" 2 } } */ +/* { dg-final { scan-assembler-times "vfmaddcsh\[ \\t\]+\{rz-sae\}\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\{%k\[0-9\]\}\{z\}\[^\n\r]*(?:\n|\[ \\t\]+#)" 1 } } */ +/* { dg-final { scan-assembler-times "vblendmps\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\{%k\[0-9\]\}\[^\{\n\r]*(?:\n|\[ \\t\]+#)" 2 } } */ +/* { dg-final { scan-assembler-times "vmovss\[ \\t\]+\[^\{\n\]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+(?:\n|\[ \\t\]+#)" 2 } } */ + +#include "avx512fp16-vfmaddcsh-1a.c" + diff --git a/gcc/testsuite/gcc.target/i386/avx512fp16vl-set1-pch-1a.c b/gcc/testsuite/gcc.target/i386/avx512fp16vl-set1-pch-1a.c new file mode 100644 index 0000000..4c5624f --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/avx512fp16vl-set1-pch-1a.c @@ -0,0 +1,20 @@ +/* { dg-do compile} */ +/* { dg-options "-O2 -mavx512fp16 -mavx512vl" } */ + +#include <immintrin.h> + +__m256h +__attribute__ ((noinline, noclone)) +test_mm256_set1_pch (_Float16 _Complex A) +{ + return _mm256_set1_pch(A); +} + +__m128h +__attribute__ ((noinline, noclone)) +test_mm_set1_pch (_Float16 _Complex A) +{ + return _mm_set1_pch(A); +} + +/* { dg-final { scan-assembler-times "vbroadcastss" 2 } } */ diff --git a/gcc/testsuite/gcc.target/i386/avx512fp16vl-set1-pch-1b.c b/gcc/testsuite/gcc.target/i386/avx512fp16vl-set1-pch-1b.c new file mode 100644 index 0000000..aebff14 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/avx512fp16vl-set1-pch-1b.c @@ -0,0 +1,57 @@ +/* { dg-do run { target avx512fp16 } } */ +/* { dg-options "-O2 -mavx512fp16 -mavx512vl" } */ + +#include<stdio.h> +#include <math.h> +#include <complex.h> + +static void do_test (void); + +#define DO_TEST do_test +#define AVX512FP16 + +#include <immintrin.h> +#include "avx512-check.h" + +static void +do_test (void) +{ + _Float16 _Complex fc = 1.0 + 1.0*I; + union + { + _Float16 _Complex a; + float b; + } u = { .a = fc }; + float ff= u.b; + + typedef union + { + float fp[8]; + __m256h m256h; + } u1; + + __m256h test256 = _mm256_set1_pch(fc); + + u1 test1; + test1.m256h = test256; + for (int i = 0; i<8; i++) + { + if (test1.fp[i] != ff) abort(); + } + + typedef union + { + float fp[4]; + __m128h m128h; + } u2; + + __m128h test128 = _mm_set1_pch(fc); + + u2 test2; + test2.m128h = test128; + for (int i = 0; i<4; i++) + { + if (test2.fp[i] != ff) abort(); + } + +} diff --git a/gcc/testsuite/gcc.target/i386/avx512fp16vl-vfcmaddcph-1a.c b/gcc/testsuite/gcc.target/i386/avx512fp16vl-vfcmaddcph-1a.c index eff1381..627241c 100644 --- a/gcc/testsuite/gcc.target/i386/avx512fp16vl-vfcmaddcph-1a.c +++ b/gcc/testsuite/gcc.target/i386/avx512fp16vl-vfcmaddcph-1a.c @@ -3,9 +3,11 @@ /* { dg-final { scan-assembler-times "vfcmaddcph\[ \\t\]+\[^\{\n\]*%ymm\[0-9\]+\[^\n\r]*%ymm\[0-9\]+(?:\n|\[ \\t\]+#)" 1 } } */ /* { dg-final { scan-assembler-times "vfcmaddcph\[ \\t\]+%ymm\[0-9\]+\[^\n\r]*%ymm\[0-9\]+\[^\n\r]*%ymm\[0-9\]+\{%k\[0-9\]\}(?:\n|\[ \\t\]+#)" 2 } } */ /* { dg-final { scan-assembler-times "vfcmaddcph\[ \\t\]+%ymm\[0-9\]+\[^\n\r]*%ymm\[0-9\]+\[^\n\r]*%ymm\[0-9\]+\{%k\[0-9\]\}\{z\}\[^\n\r]*(?:\n|\[ \\t\]+#)" 1 } } */ +/* { dg-final { scan-assembler-times "vblendmps\[ \\t\]+%ymm\[0-9\]+\[^\n\r]*%ymm\[0-9\]+\[^\n\r]*%ymm\[0-9\]+\{%k\[0-9\]\}(?:\n|\[ \\t\]+#)" 1 } } */ /* { dg-final { scan-assembler-times "vfcmaddcph\[ \\t\]+%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+(?:\n|\[ \\t\]+#)" 1 } } */ /* { dg-final { scan-assembler-times "vfcmaddcph\[ \\t\]+%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\{%k\[0-9\]\}(?:\n|\[ \\t\]+#)" 2 } } */ /* { dg-final { scan-assembler-times "vfcmaddcph\[ \\t\]+%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\{%k\[0-9\]\}\{z\}\[^\n\r]*(?:\n|\[ \\t\]+#)" 1 } } */ +/* { dg-final { scan-assembler-times "vblendmps\[ \\t\]+%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\{%k\[0-9\]\}(?:\n|\[ \\t\]+#)" 1 } } */ #include <immintrin.h> diff --git a/gcc/testsuite/gcc.target/i386/avx512fp16vl-vfmaddcph-1a.c b/gcc/testsuite/gcc.target/i386/avx512fp16vl-vfmaddcph-1a.c index b9a24d0..75cba83 100644 --- a/gcc/testsuite/gcc.target/i386/avx512fp16vl-vfmaddcph-1a.c +++ b/gcc/testsuite/gcc.target/i386/avx512fp16vl-vfmaddcph-1a.c @@ -3,9 +3,11 @@ /* { dg-final { scan-assembler-times "vfmaddcph\[ \\t\]+\[^\{\n\]*%ymm\[0-9\]+\[^\n\r]*%ymm\[0-9\]+(?:\n|\[ \\t\]+#)" 1 } } */ /* { dg-final { scan-assembler-times "vfmaddcph\[ \\t\]+%ymm\[0-9\]+\[^\n\r]*%ymm\[0-9\]+\[^\n\r]*%ymm\[0-9\]+\{%k\[0-9\]\}(?:\n|\[ \\t\]+#)" 2 } } */ /* { dg-final { scan-assembler-times "vfmaddcph\[ \\t\]+%ymm\[0-9\]+\[^\n\r]*%ymm\[0-9\]+\[^\n\r]*%ymm\[0-9\]+\{%k\[0-9\]\}\{z\}\[^\n\r]*(?:\n|\[ \\t\]+#)" 1 } } */ +/* { dg-final { scan-assembler-times "vblendmps\[ \\t\]+%ymm\[0-9\]+\[^\n\r]*%ymm\[0-9\]+\[^\n\r]*%ymm\[0-9\]+\{%k\[0-9\]\}(?:\n|\[ \\t\]+#)" 1 } } */ /* { dg-final { scan-assembler-times "vfmaddcph\[ \\t\]+%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+(?:\n|\[ \\t\]+#)" 1 } } */ /* { dg-final { scan-assembler-times "vfmaddcph\[ \\t\]+%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\{%k\[0-9\]\}(?:\n|\[ \\t\]+#)" 2 } } */ /* { dg-final { scan-assembler-times "vfmaddcph\[ \\t\]+%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\{%k\[0-9\]\}\{z\}\[^\n\r]*(?:\n|\[ \\t\]+#)" 1 } } */ +/* { dg-final { scan-assembler-times "vblendmps\[ \\t\]+%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\[^\n\r]*%xmm\[0-9\]+\{%k\[0-9\]\}(?:\n|\[ \\t\]+#)" 1 } } */ #include <immintrin.h> diff --git a/gcc/testsuite/gcc.target/i386/pieces-memset-1.c b/gcc/testsuite/gcc.target/i386/pieces-memset-1.c index 2b80326..f7487ba 100644 --- a/gcc/testsuite/gcc.target/i386/pieces-memset-1.c +++ b/gcc/testsuite/gcc.target/i386/pieces-memset-1.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-O2 -mno-avx -msse2 -mtune=generic" } */ +/* { dg-options "-O2 -mno-avx -msse2 -mtune=generic -mno-stackrealign" } */ extern char *dst; diff --git a/gcc/testsuite/gcc.target/i386/pieces-memset-4.c b/gcc/testsuite/gcc.target/i386/pieces-memset-4.c index 9256919..a12b9dd 100644 --- a/gcc/testsuite/gcc.target/i386/pieces-memset-4.c +++ b/gcc/testsuite/gcc.target/i386/pieces-memset-4.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-O2 -mno-avx -msse2 -mtune=generic" } */ +/* { dg-options "-O2 -mno-avx -msse2 -mtune=generic -mno-stackrealign" } */ extern char *dst; diff --git a/gcc/testsuite/gcc.target/i386/pieces-memset-41.c b/gcc/testsuite/gcc.target/i386/pieces-memset-41.c index f86b698..93df810 100644 --- a/gcc/testsuite/gcc.target/i386/pieces-memset-41.c +++ b/gcc/testsuite/gcc.target/i386/pieces-memset-41.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-O2 -mno-avx2 -mavx -mtune=sandybridge" } */ +/* { dg-options "-O2 -mno-avx2 -mavx -mtune=sandybridge -mno-stackrealign" } */ extern char *dst; diff --git a/gcc/testsuite/gcc.target/i386/pieces-memset-7.c b/gcc/testsuite/gcc.target/i386/pieces-memset-7.c index fd15986..0d02877 100644 --- a/gcc/testsuite/gcc.target/i386/pieces-memset-7.c +++ b/gcc/testsuite/gcc.target/i386/pieces-memset-7.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-O2 -mno-avx -msse2 -mtune=generic" } */ +/* { dg-options "-O2 -mno-avx -msse2 -mtune=generic -mno-stackrealign" } */ extern char *dst; diff --git a/gcc/testsuite/gcc.target/i386/pieces-memset-8.c b/gcc/testsuite/gcc.target/i386/pieces-memset-8.c index 7df0019..816d83e 100644 --- a/gcc/testsuite/gcc.target/i386/pieces-memset-8.c +++ b/gcc/testsuite/gcc.target/i386/pieces-memset-8.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-O2 -mno-avx2 -mavx -mtune=generic" } */ +/* { dg-options "-O2 -mno-avx2 -mavx -mtune=generic -mno-stackrealign" } */ extern char *dst; diff --git a/gcc/testsuite/gcc.target/i386/pr100704-1.c b/gcc/testsuite/gcc.target/i386/pr100704-1.c index 02461db..b292dc2 100644 --- a/gcc/testsuite/gcc.target/i386/pr100704-1.c +++ b/gcc/testsuite/gcc.target/i386/pr100704-1.c @@ -1,5 +1,5 @@ /* { dg-do compile { target { ! ia32 } } } */ -/* { dg-options "-O2 -march=x86-64" } */ +/* { dg-options "-O2 -fomit-frame-pointer -march=x86-64" } */ struct S { diff --git a/gcc/testsuite/gcc.target/i386/pr100704-2.c b/gcc/testsuite/gcc.target/i386/pr100704-2.c index 07b9bd1..d010658 100644 --- a/gcc/testsuite/gcc.target/i386/pr100704-2.c +++ b/gcc/testsuite/gcc.target/i386/pr100704-2.c @@ -1,5 +1,5 @@ /* { dg-do compile { target { ! ia32 } } } */ -/* { dg-options "-O2 -march=x86-64" } */ +/* { dg-options "-O2 -fomit-frame-pointer -march=x86-64" } */ struct S { diff --git a/gcc/testsuite/gcc.target/i386/pr102464-sqrtph.c b/gcc/testsuite/gcc.target/i386/pr102464-sqrtph.c new file mode 100644 index 0000000..8bd19c6 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr102464-sqrtph.c @@ -0,0 +1,27 @@ +/* PR target/102464. */ +/* { dg-do compile } */ +/* { dg-options "-O2 -mavx512fp16 -mavx512vl -ffast-math -ftree-vectorize" } */ + +#include<math.h> +void foo1 (_Float16* __restrict a, _Float16* b) +{ + for (int i = 0; i != 8; i++) + a[i] = sqrtf (b[i]); +} + +void foo2 (_Float16* __restrict a, _Float16* b) +{ + for (int i = 0; i != 8; i++) + a[i] = sqrt (b[i]); +} + +void foo3 (_Float16* __restrict a, _Float16* b) +{ + for (int i = 0; i != 8; i++) + a[i] = sqrtl (b[i]); +} + +/* { dg-final { scan-assembler-not "vcvtsh2s\[sd\]" } } */ +/* { dg-final { scan-assembler-not "vcvtph2p\[sd\]" } } */ +/* { dg-final { scan-assembler-not "extendhfxf" } } */ +/* { dg-final { scan-assembler-times "vsqrtph\[^\n\r\]*xmm\[0-9\]" 3 } } */ diff --git a/gcc/testsuite/gcc.target/i386/pr102464-sqrtsh.c b/gcc/testsuite/gcc.target/i386/pr102464-sqrtsh.c new file mode 100644 index 0000000..4cf0089 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr102464-sqrtsh.c @@ -0,0 +1,23 @@ +/* PR target/102464. */ +/* { dg-do compile } */ +/* { dg-options "-O2 -mavx512fp16 -ffast-math" } */ + +#include<math.h> +_Float16 foo1 (_Float16 a) +{ + return sqrtf (a); +} + +_Float16 foo2 (_Float16 a) +{ + return sqrt (a); +} + +_Float16 foo3 (_Float16 a) +{ + return sqrtl (a); +} + +/* { dg-final { scan-assembler-not "vcvtsh2s\[sd\]" } } */ +/* { dg-final { scan-assembler-not "extendhfxf" } } */ +/* { dg-final { scan-assembler-times "vsqrtsh\[^\n\r\]*xmm\[0-9\]" 3 } } */ diff --git a/gcc/testsuite/gcc.target/i386/pr102483-2.c b/gcc/testsuite/gcc.target/i386/pr102483-2.c new file mode 100644 index 0000000..d477c53 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr102483-2.c @@ -0,0 +1,26 @@ +/* { dg-do run } */ +/* { dg-require-effective-target sse4 } */ +/* { dg-options "-O2 -msse4.1" } */ + +#include "sse4_1-check.h" + +#include "pr102483.c" + +static void +sse4_1_test () +{ + char p[4] = { -103, 23, 41, -56 }; + unsigned char up[4] = { 100, 30, 255, 9 }; + + char res = reduce_add (p); + if (res != -95) + abort (); + if (reduce_smin (p) != -103) + abort (); + if (reduce_smax (p) != 41) + abort (); + if (reduce_umin (up) != 9) + abort (); + if (reduce_umax (up) != 255) + abort(); +} diff --git a/gcc/testsuite/gcc.target/i386/pr102483.c b/gcc/testsuite/gcc.target/i386/pr102483.c new file mode 100644 index 0000000..681b575 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr102483.c @@ -0,0 +1,58 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -msse4.1 -ftree-vectorize -fdump-tree-optimized" } */ +/* { dg-final { scan-tree-dump-times "\.REDUC_MIN" 2 "optimized" } } */ +/* { dg-final { scan-tree-dump-times "\.REDUC_MAX" 2 "optimized" } } */ +/* { dg-final { scan-tree-dump-times "\.REDUC_PLUS" 1 "optimized" } } */ + +char +__attribute__((noipa, optimize("Ofast"),target("sse4.1"))) +reduce_add (char* p) +{ + char sum = 0; + for (int i = 0; i != 4; i++) + sum += p[i]; + return sum; +} + +#define MAX(a, b) ((a) > (b) ? (a) : (b)) +#define MIN(a, b) ((a) > (b) ? (b) : (a)) + +unsigned char +__attribute__((noipa, optimize("Ofast"),target("sse4.1"))) +reduce_umax (unsigned char* p) +{ + unsigned char sum = p[0]; + for (int i = 0; i != 4; i++) + sum = MAX(sum, p[i]); + return sum; +} + +unsigned char +__attribute__((noipa, optimize("Ofast"),target("sse4.1"))) +reduce_umin (unsigned char* p) +{ + unsigned char sum = p[0]; + for (int i = 0; i != 4; i++) + sum = MIN(sum, p[i]); + return sum; +} + +char +__attribute__((noipa, optimize("Ofast"),target("sse4.1"))) +reduce_smax (char* p) +{ + char sum = p[0]; + for (int i = 0; i != 4; i++) + sum = MAX(sum, p[i]); + return sum; +} + +char +__attribute__((noipa, optimize("Ofast"),target("sse4.1"))) +reduce_smin (char* p) +{ + char sum = p[0]; + for (int i = 0; i != 4; i++) + sum = MIN(sum, p[i]); + return sum; +} diff --git a/gcc/testsuite/gcc.target/i386/pr102627.c b/gcc/testsuite/gcc.target/i386/pr102627.c new file mode 100644 index 0000000..8ab9aca --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr102627.c @@ -0,0 +1,41 @@ +/* PR rtl-optimization/102627 */ +/* { dg-do run } */ +/* { dg-options "-O1" } */ + +int a, f, l, m, q, c, d, g; +long b, e; +struct g { + signed h; + signed i; + unsigned j; + unsigned k; +}; +unsigned n; +char o; +int *p = &m; +long r(int s) { return s && b ?: b; } +long __attribute__((noipa)) v() { + l = 0 || r(n & o); + return q; +} +void w(int, unsigned, struct g x) { + c ?: a; + for (; d < 2; d++) + *p = x.k; +} +struct g __attribute__((noipa)) y() { + struct g h = {3, 908, 1, 20}; + for (; g; g++) + ; + return h; +} +int main() { + long t; + struct g u = y(); + t = e << f; + w(0, t, u); + v(0, 4, 4, 4); + if (m != 20) + __builtin_abort (); + return 0; +} diff --git a/gcc/testsuite/gcc.target/i386/pr102761.c b/gcc/testsuite/gcc.target/i386/pr102761.c new file mode 100644 index 0000000..58ff27e --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr102761.c @@ -0,0 +1,11 @@ +/* PR target/102761 */ +/* { dg-do compile } */ +/* { dg-options "-O1" } */ + +int foo (void); + +void +bar (void) +{ + asm volatile ("%a0" : : "X"(foo () ? 2 : 1)); /* { dg-error "invalid constraints for operand" } */ +} diff --git a/gcc/testsuite/gcc.target/i386/pr102812.c b/gcc/testsuite/gcc.target/i386/pr102812.c new file mode 100644 index 0000000..bad4fa9 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr102812.c @@ -0,0 +1,12 @@ +/* PR target/102812 */ +/* { dg-do compile } */ +/* { dg-options "-O2 -msse4 -mno-avx" } */ +/* { dg-final { scan-assembler-not "vmovdqa64\t" } } */ +/* { dg-final { scan-assembler "movdqa\t" } } */ + +typedef _Float16 v8hf __attribute__((__vector_size__ (16))); + +v8hf t (_Float16 a) +{ + return (v8hf) {a, 0, 0, 0, 0, 0, 0, 0}; +} diff --git a/gcc/testsuite/gcc.target/i386/pr22076.c b/gcc/testsuite/gcc.target/i386/pr22076.c index 427ffcd..766b732 100644 --- a/gcc/testsuite/gcc.target/i386/pr22076.c +++ b/gcc/testsuite/gcc.target/i386/pr22076.c @@ -1,9 +1,9 @@ /* { dg-do compile } */ -/* { dg-options "-O2 -fomit-frame-pointer -mmmx -mno-sse2" } */ +/* { dg-options "-O2 -fomit-frame-pointer -mmmx -msse -mno-sse2" } */ /* { dg-additional-options "-fno-common" { target *-*-darwin* } } */ /* { dg-additional-options "-mdynamic-no-pic" { target { ia32 && *-*-darwin* } } } */ -#include <mmintrin.h> +#include <xmmintrin.h> __m64 x; @@ -12,7 +12,7 @@ void test () __m64 mm0 = (__m64)(__v8qi) {1,2,3,4,5,6,7,8}; __m64 mm1 = (__m64)(__v8qi) {11,22,33,44,55,66,77,88}; - x = _mm_add_pi8 (mm0, mm1); + x = _mm_sad_pu8 (mm0, mm1); } /* { dg-final { scan-assembler-times "movq" 2 } } */ diff --git a/gcc/testsuite/gcc.target/i386/pr85730.c b/gcc/testsuite/gcc.target/i386/pr85730.c new file mode 100644 index 0000000..b279016 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr85730.c @@ -0,0 +1,95 @@ +/* PR target/85730 */ +/* { dg-do compile } */ +/* { dg-options "-O2 -mno-sse4" } */ + +typedef char V __attribute__((vector_size(4))); + +V +test_and (V v, char c) +{ + v[0] &= c; + + return v; +} + +/* { dg-final { scan-assembler "\[ \t\]andb" } } */ + +V +test_or (V v, char c) +{ + v[0] |= c; + + return v; +} + +/* { dg-final { scan-assembler "\[ \t\]orb" } } */ + +V +test_xor (V v, char c) +{ + v[0] ^= c; + + return v; +} + +/* { dg-final { scan-assembler "\[ \t\]xorb" } } */ + +V +test_not (V v) +{ + v[0] = ~v[0]; + + return v; +} + +/* { dg-final { scan-assembler "\[ \t\]notb" } } */ + +V +test_sal (V v) +{ + v[0] <<= 3; + + return v; +} + +/* { dg-final { scan-assembler "\[ \t\]salb" } } */ + +V +test_sar (V v) +{ + v[0] >>= 3; + + return v; +} + +/* { dg-final { scan-assembler "\[ \t\]sarb" } } */ + +V +test_add (V v, char c) +{ + v[0] += c; + + return v; +} + +/* { dg-final { scan-assembler "\[ \t\]addb" } } */ + +V +test_sub (V v, char c) +{ + v[0] -= c; + + return v; +} + +/* { dg-final { scan-assembler "\[ \t\]subb" } } */ + +V +test_neg (V v) +{ + v[0] = -v[0]; + + return v; +} + +/* { dg-final { scan-assembler "\[ \t\]negb" } } */ diff --git a/gcc/testsuite/gcc.target/i386/pr90773-1.c b/gcc/testsuite/gcc.target/i386/pr90773-1.c index 4fd5a40..d51e287 100644 --- a/gcc/testsuite/gcc.target/i386/pr90773-1.c +++ b/gcc/testsuite/gcc.target/i386/pr90773-1.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-O2 -msse2 -mtune=generic" } */ +/* { dg-options "-O2 -msse2 -mtune=generic -mno-stackrealign" } */ extern char *dst, *src; diff --git a/gcc/testsuite/gcc.target/i386/sse-13.c b/gcc/testsuite/gcc.target/i386/sse-13.c index f6d54e3..e285c30 100644 --- a/gcc/testsuite/gcc.target/i386/sse-13.c +++ b/gcc/testsuite/gcc.target/i386/sse-13.c @@ -806,9 +806,11 @@ #define __builtin_ia32_vfnmsubsh3_maskz(A, B, C, D, E) __builtin_ia32_vfnmsubsh3_maskz(A, B, C, D, 8) #define __builtin_ia32_vfcmaddcph512_round(A, B, C, D) __builtin_ia32_vfcmaddcph512_round(A, B, C, 8) #define __builtin_ia32_vfcmaddcph512_mask_round(A, C, D, B, E) __builtin_ia32_vfcmaddcph512_mask_round(A, C, D, B, 8) +#define __builtin_ia32_vfcmaddcph512_mask3_round(A, C, D, B, E) __builtin_ia32_vfcmaddcph512_mask3_round(A, C, D, B, 8) #define __builtin_ia32_vfcmaddcph512_maskz_round(B, C, D, A, E) __builtin_ia32_vfcmaddcph512_maskz_round(B, C, D, A, 8) #define __builtin_ia32_vfmaddcph512_round(A, B, C, D) __builtin_ia32_vfmaddcph512_round(A, B, C, 8) #define __builtin_ia32_vfmaddcph512_mask_round(A, C, D, B, E) __builtin_ia32_vfmaddcph512_mask_round(A, C, D, B, 8) +#define __builtin_ia32_vfmaddcph512_mask3_round(A, C, D, B, E) __builtin_ia32_vfmaddcph512_mask3_round(A, C, D, B, 8) #define __builtin_ia32_vfmaddcph512_maskz_round(B, C, D, A, E) __builtin_ia32_vfmaddcph512_maskz_round(B, C, D, A, 8) #define __builtin_ia32_vfmulcph512_round(A, B, C) __builtin_ia32_vfmulcph512_round(A, B, 8) #define __builtin_ia32_vfmulcph512_mask_round(A, C, D, B, E) __builtin_ia32_vfmulcph512_mask_round(A, C, D, B, 8) @@ -816,9 +818,11 @@ #define __builtin_ia32_vfcmulcph512_mask_round(A, C, D, B, E) __builtin_ia32_vfcmulcph512_mask_round(A, C, D, B, 8) #define __builtin_ia32_vfmaddcsh_round(A, B, C, D) __builtin_ia32_vfmaddcsh_round(A, B, C, 8) #define __builtin_ia32_vfmaddcsh_mask_round(A, C, D, B, E) __builtin_ia32_vfmaddcsh_mask_round(A, C, D, B, 8) +#define __builtin_ia32_vfmaddcsh_mask3_round(A, C, D, B, E) __builtin_ia32_vfmaddcsh_mask3_round(A, C, D, B, 8) #define __builtin_ia32_vfmaddcsh_maskz_round(B, C, D, A, E) __builtin_ia32_vfmaddcsh_maskz_round(B, C, D, A, 8) #define __builtin_ia32_vfcmaddcsh_round(A, B, C, D) __builtin_ia32_vfcmaddcsh_round(A, B, C, 8) #define __builtin_ia32_vfcmaddcsh_mask_round(A, C, D, B, E) __builtin_ia32_vfcmaddcsh_mask_round(A, C, D, B, 8) +#define __builtin_ia32_vfcmaddcsh_mask3_round(A, C, D, B, E) __builtin_ia32_vfcmaddcsh_mask3_round(A, C, D, B, 8) #define __builtin_ia32_vfcmaddcsh_maskz_round(B, C, D, A, E) __builtin_ia32_vfcmaddcsh_maskz_round(B, C, D, A, 8) #define __builtin_ia32_vfmulcsh_round(A, B, C) __builtin_ia32_vfmulcsh_round(A, B, 8) #define __builtin_ia32_vfmulcsh_mask_round(A, C, D, B, E) __builtin_ia32_vfmulcsh_mask_round(A, C, D, B, 8) diff --git a/gcc/testsuite/gcc.target/i386/sse-23.c b/gcc/testsuite/gcc.target/i386/sse-23.c index 9825126..f71a7b2 100644 --- a/gcc/testsuite/gcc.target/i386/sse-23.c +++ b/gcc/testsuite/gcc.target/i386/sse-23.c @@ -807,9 +807,11 @@ #define __builtin_ia32_vfnmsubsh3_maskz(A, B, C, D, E) __builtin_ia32_vfnmsubsh3_maskz(A, B, C, D, 8) #define __builtin_ia32_vfcmaddcph512_round(A, B, C, D) __builtin_ia32_vfcmaddcph512_round(A, B, C, 8) #define __builtin_ia32_vfcmaddcph512_mask_round(A, C, D, B, E) __builtin_ia32_vfcmaddcph512_mask_round(A, C, D, B, 8) +#define __builtin_ia32_vfcmaddcph512_mask3_round(A, C, D, B, E) __builtin_ia32_vfcmaddcph512_mask3_round(A, C, D, B, 8) #define __builtin_ia32_vfcmaddcph512_maskz_round(B, C, D, A, E) __builtin_ia32_vfcmaddcph512_maskz_round(B, C, D, A, 8) #define __builtin_ia32_vfmaddcph512_round(A, B, C, D) __builtin_ia32_vfmaddcph512_round(A, B, C, 8) #define __builtin_ia32_vfmaddcph512_mask_round(A, C, D, B, E) __builtin_ia32_vfmaddcph512_mask_round(A, C, D, B, 8) +#define __builtin_ia32_vfmaddcph512_mask3_round(A, C, D, B, E) __builtin_ia32_vfmaddcph512_mask3_round(A, C, D, B, 8) #define __builtin_ia32_vfmaddcph512_maskz_round(B, C, D, A, E) __builtin_ia32_vfmaddcph512_maskz_round(B, C, D, A, 8) #define __builtin_ia32_vfmulcph512_round(A, B, C) __builtin_ia32_vfmulcph512_round(A, B, 8) #define __builtin_ia32_vfmulcph512_mask_round(A, C, D, B, E) __builtin_ia32_vfmulcph512_mask_round(A, C, D, B, 8) @@ -817,9 +819,11 @@ #define __builtin_ia32_vfcmulcph512_mask_round(A, C, D, B, E) __builtin_ia32_vfcmulcph512_mask_round(A, C, D, B, 8) #define __builtin_ia32_vfmaddcsh_round(A, B, C, D) __builtin_ia32_vfmaddcsh_round(A, B, C, 8) #define __builtin_ia32_vfmaddcsh_mask_round(A, C, D, B, E) __builtin_ia32_vfmaddcsh_mask_round(A, C, D, B, 8) +#define __builtin_ia32_vfmaddcsh_mask3_round(A, C, D, B, E) __builtin_ia32_vfmaddcsh_mask3_round(A, C, D, B, 8) #define __builtin_ia32_vfmaddcsh_maskz_round(B, C, D, A, E) __builtin_ia32_vfmaddcsh_maskz_round(B, C, D, A, 8) #define __builtin_ia32_vfcmaddcsh_round(A, B, C, D) __builtin_ia32_vfcmaddcsh_round(A, B, C, 8) #define __builtin_ia32_vfcmaddcsh_mask_round(A, C, D, B, E) __builtin_ia32_vfcmaddcsh_mask_round(A, C, D, B, 8) +#define __builtin_ia32_vfcmaddcsh_mask3_round(A, C, D, B, E) __builtin_ia32_vfcmaddcsh_mask3_round(A, C, D, B, 8) #define __builtin_ia32_vfcmaddcsh_maskz_round(B, C, D, A, E) __builtin_ia32_vfcmaddcsh_maskz_round(B, C, D, A, 8) #define __builtin_ia32_vfmulcsh_round(A, B, C) __builtin_ia32_vfmulcsh_round(A, B, 8) #define __builtin_ia32_vfmulcsh_mask_round(A, C, D, B, E) __builtin_ia32_vfmulcsh_mask_round(A, C, D, B, 8) diff --git a/gcc/testsuite/gcc.target/i386/sse2-mmx-paddsb-2.c b/gcc/testsuite/gcc.target/i386/sse2-mmx-paddsb-2.c index c677884..ad4726b 100644 --- a/gcc/testsuite/gcc.target/i386/sse2-mmx-paddsb-2.c +++ b/gcc/testsuite/gcc.target/i386/sse2-mmx-paddsb-2.c @@ -29,5 +29,5 @@ char baz() /* { dg-final { scan-assembler-times "movl\[ \\t\]+\\\$3," 1 } } */ /* { dg-final { scan-assembler-times "movl\[ \\t\]+\\\$127," 1 } } */ -/* { dg-final { scan-assembler-times "movl\[ \\t\]+\\\$-128," 1 } } */ +/* { dg-final { scan-assembler-times "movl\[ \\t\]+\\\$-?128," 1 } } */ /* { dg-final { scan-assembler-not "paddsb\[ \\t\]+%xmm\[0-9\]+" } } */ diff --git a/gcc/testsuite/gcc.target/i386/sse2-mmx-paddusb-2.c b/gcc/testsuite/gcc.target/i386/sse2-mmx-paddusb-2.c index b20891c..1d3bc8b 100644 --- a/gcc/testsuite/gcc.target/i386/sse2-mmx-paddusb-2.c +++ b/gcc/testsuite/gcc.target/i386/sse2-mmx-paddusb-2.c @@ -20,6 +20,6 @@ char bar() } /* { dg-final { scan-assembler-times "movl\[ \\t\]+\\\$3," 1 } } */ -/* { dg-final { scan-assembler-times "movl\[ \\t\]+\\\$-1," 1 } } */ +/* { dg-final { scan-assembler-times "movl\[ \\t\]+\\\$(?:255|-1)," 1 } } */ /* { dg-final { scan-assembler-not "paddusb\[ \\t\]+%xmm\[0-9\]+" } } */ diff --git a/gcc/testsuite/gcc.target/i386/sse2-mmx-psubsb-2.c b/gcc/testsuite/gcc.target/i386/sse2-mmx-psubsb-2.c index 4fc2920..68b57f2 100644 --- a/gcc/testsuite/gcc.target/i386/sse2-mmx-psubsb-2.c +++ b/gcc/testsuite/gcc.target/i386/sse2-mmx-psubsb-2.c @@ -28,6 +28,6 @@ char baz() } /* { dg-final { scan-assembler-times "movl\[ \\t\]+\\\$3," 1 } } */ -/* { dg-final { scan-assembler-times "movl\[ \\t\]+\\\$-128," 1 } } */ +/* { dg-final { scan-assembler-times "movl\[ \\t\]+\\\$-?128," 1 } } */ /* { dg-final { scan-assembler-times "movl\[ \\t\]+\\\$127," 1 } } */ /* { dg-final { scan-assembler-not "paddsb\[ \\t\]+%xmm\[0-9\]+" } } */ diff --git a/gcc/testsuite/gcc.target/i386/sse2-v1ti-logic-2.c b/gcc/testsuite/gcc.target/i386/sse2-v1ti-logic-2.c new file mode 100644 index 0000000..3ec6455 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/sse2-v1ti-logic-2.c @@ -0,0 +1,53 @@ +/* { dg-do compile { target int128 } } */ +/* { dg-options "-O2 -msse2" } */ + +typedef unsigned __int128 v1ti __attribute__ ((__vector_size__ (16))); + +v1ti x; +v1ti y; +v1ti z; + +void and2() +{ + x &= y; +} + +void and3() +{ + x = y & z; +} + +void ior2() +{ + x |= y; +} + +void ior3() +{ + x = y | z; +} + + +void xor2() +{ + x ^= y; +} + +void xor3() +{ + x = y ^ z; +} + +void not1() +{ + x = ~x; +} + +void not2() +{ + x = ~y; +} + +/* { dg-final { scan-assembler-times "pand" 2 } } */ +/* { dg-final { scan-assembler-times "por" 2 } } */ +/* { dg-final { scan-assembler-times "pxor" 4 } } */ diff --git a/gcc/testsuite/gcc.target/i386/sse2-v1ti-logic.c b/gcc/testsuite/gcc.target/i386/sse2-v1ti-logic.c new file mode 100644 index 0000000..130a89b --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/sse2-v1ti-logic.c @@ -0,0 +1,28 @@ +/* { dg-do compile { target int128 } } */ +/* { dg-options "-O2 -msse2" } */ + +typedef unsigned __int128 v1ti __attribute__ ((__vector_size__ (16))); + +v1ti and(v1ti x, v1ti y) +{ + return x & y; +} + +v1ti ior(v1ti x, v1ti y) +{ + return x | y; +} + +v1ti xor(v1ti x, v1ti y) +{ + return x ^ y; +} + +v1ti not(v1ti x) +{ + return ~x; +} + +/* { dg-final { scan-assembler "pand" } } */ +/* { dg-final { scan-assembler "por" } } */ +/* { dg-final { scan-assembler-times "pxor" 2 } } */ diff --git a/gcc/testsuite/gcc.target/i386/sse2-v1ti-shift.c b/gcc/testsuite/gcc.target/i386/sse2-v1ti-shift.c new file mode 100644 index 0000000..dbae418 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/sse2-v1ti-shift.c @@ -0,0 +1,212 @@ +/* { dg-do run { target int128 } } */ +/* { dg-options "-O2 -msse2" } */ +/* { dg-require-effective-target sse2 } */ + +typedef unsigned __int128 v1ti __attribute__ ((__vector_size__ (16))); +typedef unsigned __int128 ti; + +ti ashl(ti x, unsigned int i) { return x << i; } +ti lshr(ti x, unsigned int i) { return x >> i; } +ti rotr(ti x, unsigned int i) { return (x >> i) | (x << (128-i)); } + +v1ti ashl_1(v1ti x) { return x << 1; } +v1ti ashl_2(v1ti x) { return x << 2; } +v1ti ashl_7(v1ti x) { return x << 7; } +v1ti ashl_8(v1ti x) { return x << 8; } +v1ti ashl_9(v1ti x) { return x << 9; } +v1ti ashl_15(v1ti x) { return x << 15; } +v1ti ashl_16(v1ti x) { return x << 16; } +v1ti ashl_17(v1ti x) { return x << 17; } +v1ti ashl_31(v1ti x) { return x << 31; } +v1ti ashl_32(v1ti x) { return x << 32; } +v1ti ashl_33(v1ti x) { return x << 33; } +v1ti ashl_63(v1ti x) { return x << 63; } +v1ti ashl_64(v1ti x) { return x << 64; } +v1ti ashl_65(v1ti x) { return x << 65; } +v1ti ashl_72(v1ti x) { return x << 72; } +v1ti ashl_95(v1ti x) { return x << 95; } +v1ti ashl_96(v1ti x) { return x << 96; } +v1ti ashl_97(v1ti x) { return x << 97; } +v1ti ashl_111(v1ti x) { return x << 111; } +v1ti ashl_112(v1ti x) { return x << 112; } +v1ti ashl_113(v1ti x) { return x << 113; } +v1ti ashl_119(v1ti x) { return x << 119; } +v1ti ashl_120(v1ti x) { return x << 120; } +v1ti ashl_121(v1ti x) { return x << 121; } +v1ti ashl_126(v1ti x) { return x << 126; } +v1ti ashl_127(v1ti x) { return x << 127; } + +v1ti lshr_1(v1ti x) { return x >> 1; } +v1ti lshr_2(v1ti x) { return x >> 2; } +v1ti lshr_7(v1ti x) { return x >> 7; } +v1ti lshr_8(v1ti x) { return x >> 8; } +v1ti lshr_9(v1ti x) { return x >> 9; } +v1ti lshr_15(v1ti x) { return x >> 15; } +v1ti lshr_16(v1ti x) { return x >> 16; } +v1ti lshr_17(v1ti x) { return x >> 17; } +v1ti lshr_31(v1ti x) { return x >> 31; } +v1ti lshr_32(v1ti x) { return x >> 32; } +v1ti lshr_33(v1ti x) { return x >> 33; } +v1ti lshr_63(v1ti x) { return x >> 63; } +v1ti lshr_64(v1ti x) { return x >> 64; } +v1ti lshr_65(v1ti x) { return x >> 65; } +v1ti lshr_72(v1ti x) { return x >> 72; } +v1ti lshr_95(v1ti x) { return x >> 95; } +v1ti lshr_96(v1ti x) { return x >> 96; } +v1ti lshr_97(v1ti x) { return x >> 97; } +v1ti lshr_111(v1ti x) { return x >> 111; } +v1ti lshr_112(v1ti x) { return x >> 112; } +v1ti lshr_113(v1ti x) { return x >> 113; } +v1ti lshr_119(v1ti x) { return x >> 119; } +v1ti lshr_120(v1ti x) { return x >> 120; } +v1ti lshr_121(v1ti x) { return x >> 121; } +v1ti lshr_126(v1ti x) { return x >> 126; } +v1ti lshr_127(v1ti x) { return x >> 127; } + +v1ti rotr_1(v1ti x) { return (x >> 1) | (x << 127); } +v1ti rotr_2(v1ti x) { return (x >> 2) | (x << 126); } +v1ti rotr_7(v1ti x) { return (x >> 7) | (x << 121); } +v1ti rotr_8(v1ti x) { return (x >> 8) | (x << 120); } +v1ti rotr_9(v1ti x) { return (x >> 9) | (x << 119); } +v1ti rotr_15(v1ti x) { return (x >> 15) | (x << 113); } +v1ti rotr_16(v1ti x) { return (x >> 16) | (x << 112); } +v1ti rotr_17(v1ti x) { return (x >> 17) | (x << 111); } +v1ti rotr_31(v1ti x) { return (x >> 31) | (x << 97); } +v1ti rotr_32(v1ti x) { return (x >> 32) | (x << 96); } +v1ti rotr_33(v1ti x) { return (x >> 33) | (x << 95); } +v1ti rotr_63(v1ti x) { return (x >> 63) | (x << 65); } +v1ti rotr_64(v1ti x) { return (x >> 64) | (x << 64); } +v1ti rotr_65(v1ti x) { return (x >> 65) | (x << 63); } +v1ti rotr_72(v1ti x) { return (x >> 72) | (x << 56); } +v1ti rotr_95(v1ti x) { return (x >> 95) | (x << 33); } +v1ti rotr_96(v1ti x) { return (x >> 96) | (x << 32); } +v1ti rotr_97(v1ti x) { return (x >> 97) | (x << 31); } +v1ti rotr_111(v1ti x) { return (x >> 111) | (x << 17); } +v1ti rotr_112(v1ti x) { return (x >> 112) | (x << 16); } +v1ti rotr_113(v1ti x) { return (x >> 113) | (x << 15); } +v1ti rotr_119(v1ti x) { return (x >> 119) | (x << 9); } +v1ti rotr_120(v1ti x) { return (x >> 120) | (x << 8); } +v1ti rotr_121(v1ti x) { return (x >> 121) | (x << 7); } +v1ti rotr_126(v1ti x) { return (x >> 126) | (x << 2); } +v1ti rotr_127(v1ti x) { return (x >> 127) | (x << 1); } + + +typedef v1ti (*fun)(v1ti); + +struct { + unsigned int i; + fun ashl; + fun lshr; + fun rotr; +} table[26] = { + { 1, ashl_1, lshr_1, rotr_1 }, + { 2, ashl_2, lshr_2, rotr_2 }, + { 7, ashl_7, lshr_7, rotr_7 }, + { 8, ashl_8, lshr_8, rotr_8 }, + { 9, ashl_9, lshr_9, rotr_9 }, + { 15, ashl_15, lshr_15, rotr_15 }, + { 16, ashl_16, lshr_16, rotr_16 }, + { 17, ashl_17, lshr_17, rotr_17 }, + { 31, ashl_31, lshr_31, rotr_31 }, + { 32, ashl_32, lshr_32, rotr_32 }, + { 33, ashl_33, lshr_33, rotr_33 }, + { 63, ashl_63, lshr_63, rotr_63 }, + { 64, ashl_64, lshr_64, rotr_64 }, + { 65, ashl_65, lshr_65, rotr_65 }, + { 72, ashl_72, lshr_72, rotr_72 }, + { 95, ashl_95, lshr_95, rotr_95 }, + { 96, ashl_96, lshr_96, rotr_96 }, + { 97, ashl_97, lshr_97, rotr_97 }, + { 111, ashl_111, lshr_111, rotr_111 }, + { 112, ashl_112, lshr_112, rotr_112 }, + { 113, ashl_113, lshr_113, rotr_113 }, + { 119, ashl_119, lshr_119, rotr_119 }, + { 120, ashl_120, lshr_120, rotr_120 }, + { 121, ashl_121, lshr_121, rotr_121 }, + { 126, ashl_126, lshr_126, rotr_126 }, + { 127, ashl_127, lshr_127, rotr_127 } +}; + +void test(ti x) +{ + unsigned int i; + v1ti t = (v1ti)x; + + for (i=0; i<(sizeof(table)/sizeof(table[0])); i++) { + if ((ti)(*table[i].ashl)(t) != ashl(x,table[i].i)) + __builtin_abort(); + if ((ti)(*table[i].lshr)(t) != lshr(x,table[i].i)) + __builtin_abort(); + if ((ti)(*table[i].rotr)(t) != rotr(x,table[i].i)) + __builtin_abort(); + } +} + +int main() +{ + ti x; + + x = ((ti)0x0011223344556677ull)<<64 | 0x8899aabbccddeeffull; + test(x); + x = ((ti)0xffeeddccbbaa9988ull)<<64 | 0x7766554433221100ull; + test(x); + x = ((ti)0x0123456789abcdefull)<<64 | 0x0123456789abcdefull; + test(x); + x = ((ti)0xfedcba9876543210ull)<<64 | 0xfedcba9876543210ull; + test(x); + x = ((ti)0x0123456789abcdefull)<<64 | 0xfedcba9876543210ull; + test(x); + x = ((ti)0xfedcba9876543210ull)<<64 | 0x0123456789abcdefull; + test(x); + x = 0; + test(x); + x = 0xffffffffffffffffull; + test(x); + x = ((ti)0xffffffffffffffffull)<<64; + test(x); + x = ((ti)0xffffffffffffffffull)<<64 | 0xffffffffffffffffull; + test(x); + x = ((ti)0x5a5a5a5a5a5a5a5aull)<<64 | 0x5a5a5a5a5a5a5a5aull; + test(x); + x = ((ti)0xa5a5a5a5a5a5a5a5ull)<<64 | 0xa5a5a5a5a5a5a5a5ull; + test(x); + x = 0xffull; + test(x); + x = 0xff00ull; + test(x); + x = 0xff0000ull; + test(x); + x = 0xff000000ull; + test(x); + x = 0xff00000000ull; + test(x); + x = 0xff0000000000ull; + test(x); + x = 0xff000000000000ull; + test(x); + x = 0xff00000000000000ull; + test(x); + x = ((ti)0xffull)<<64; + test(x); + x = ((ti)0xff00ull)<<64; + test(x); + x = ((ti)0xff0000ull)<<64; + test(x); + x = ((ti)0xff000000ull)<<64; + test(x); + x = ((ti)0xff00000000ull)<<64; + test(x); + x = ((ti)0xff0000000000ull)<<64; + test(x); + x = ((ti)0xff000000000000ull)<<64; + test(x); + x = ((ti)0xff00000000000000ull)<<64; + test(x); + x = 0xdeadbeefcafebabeull; + test(x); + x = ((ti)0xdeadbeefcafebabeull)<<64; + test(x); + + return 0; +} + diff --git a/gcc/testsuite/gcc.target/mips/msa-insert-split.c b/gcc/testsuite/gcc.target/mips/msa-insert-split.c index 50f3b8a..9ad5987 100644 --- a/gcc/testsuite/gcc.target/mips/msa-insert-split.c +++ b/gcc/testsuite/gcc.target/mips/msa-insert-split.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-mfp64 -mhard-float -mmsa" } */ +/* { dg-options "-fno-tree-vectorize -mfp64 -mhard-float -mmsa" } */ /* { dg-skip-if "code quality test" { *-*-* } { "-O0" } { "" } } */ typedef double v2f64 __attribute__ ((vector_size (16))); diff --git a/gcc/testsuite/gcc.target/powerpc/builtins-1.c b/gcc/testsuite/gcc.target/powerpc/builtins-1.c index 83aed5a..2dafa90 100644 --- a/gcc/testsuite/gcc.target/powerpc/builtins-1.c +++ b/gcc/testsuite/gcc.target/powerpc/builtins-1.c @@ -317,10 +317,10 @@ int main () /* { dg-final { scan-assembler-times "vctuxs" 2 } } */ /* { dg-final { scan-assembler-times "vmrghb" 4 { target be } } } */ -/* { dg-final { scan-assembler-times "vmrghb" 5 { target le } } } */ +/* { dg-final { scan-assembler-times "vmrghb" 6 { target le } } } */ /* { dg-final { scan-assembler-times "vmrghh" 8 } } */ -/* { dg-final { scan-assembler-times "xxmrghw" 8 } } */ -/* { dg-final { scan-assembler-times "xxmrglw" 8 } } */ +/* { dg-final { scan-assembler-times "xxmrghw" 4 } } */ +/* { dg-final { scan-assembler-times "xxmrglw" 4 } } */ /* { dg-final { scan-assembler-times "vmrglh" 8 } } */ /* { dg-final { scan-assembler-times "xxlnor" 6 } } */ /* { dg-final { scan-assembler-times {\mvpkudus\M} 1 } } */ @@ -347,7 +347,7 @@ int main () /* { dg-final { scan-assembler-times "vspltb" 6 } } */ /* { dg-final { scan-assembler-times "vspltw" 0 } } */ /* { dg-final { scan-assembler-times "vmrgow" 8 } } */ -/* { dg-final { scan-assembler-times "vmrglb" 5 { target le } } } */ +/* { dg-final { scan-assembler-times "vmrglb" 4 { target le } } } */ /* { dg-final { scan-assembler-times "vmrglb" 6 { target be } } } */ /* { dg-final { scan-assembler-times "vmrgew" 8 } } */ /* { dg-final { scan-assembler-times "vsplth" 8 } } */ diff --git a/gcc/testsuite/gcc.target/powerpc/dform-1.c b/gcc/testsuite/gcc.target/powerpc/dform-1.c index fac3923..1a0b0cf 100644 --- a/gcc/testsuite/gcc.target/powerpc/dform-1.c +++ b/gcc/testsuite/gcc.target/powerpc/dform-1.c @@ -1,6 +1,8 @@ /* { dg-do compile { target { powerpc*-*-* && lp64 } } } */ /* { dg-require-effective-target powerpc_p9vector_ok } */ -/* { dg-options "-mpower9-vector -O2" } */ +/* Now O2 enables vectorization by default, which makes expected scalar + loads gone, so simply disable it. */ +/* { dg-options "-mpower9-vector -O2 -fno-tree-vectorize" } */ #ifndef TYPE #define TYPE double diff --git a/gcc/testsuite/gcc.target/powerpc/dform-2.c b/gcc/testsuite/gcc.target/powerpc/dform-2.c index 9947330..cc91f55 100644 --- a/gcc/testsuite/gcc.target/powerpc/dform-2.c +++ b/gcc/testsuite/gcc.target/powerpc/dform-2.c @@ -1,6 +1,8 @@ /* { dg-do compile { target { powerpc*-*-* && lp64 } } } */ /* { dg-require-effective-target powerpc_p9vector_ok } */ -/* { dg-options "-mpower9-vector -O2" } */ +/* Now O2 enables vectorization by default, which generates unexpected float + conversion for vector construction, so simply disable it. */ +/* { dg-options "-mpower9-vector -O2 -fno-tree-vectorize" } */ #ifndef TYPE #define TYPE float diff --git a/gcc/testsuite/gcc.target/powerpc/p10_vec_xl_sext.c b/gcc/testsuite/gcc.target/powerpc/p10_vec_xl_sext.c new file mode 100644 index 0000000..78e72ac --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/p10_vec_xl_sext.c @@ -0,0 +1,35 @@ +/* { dg-do compile } */ +/* { dg-require-effective-target int128 } */ +/* { dg-require-effective-target power10_ok } */ +/* { dg-options "-mdejagnu-cpu=power10 -O2" } */ + +#include <altivec.h> + +vector signed __int128 +foo1 (signed long a, signed char *b) +{ + return vec_xl_sext (a, b); +} + +vector signed __int128 +foo2 (signed long a, signed short *b) +{ + return vec_xl_sext (a, b); +} + +vector signed __int128 +foo3 (signed long a, signed int *b) +{ + return vec_xl_sext (a, b); +} + +vector signed __int128 +foo4 (signed long a, signed long *b) +{ + return vec_xl_sext (a, b); +} + +/* { dg-final { scan-assembler-times {\mvextsd2q\M} 4 } } */ +/* { dg-final { scan-assembler-times {\mvextsb2d\M} 1 } } */ +/* { dg-final { scan-assembler-times {\mvextsh2d\M} 1 } } */ +/* { dg-final { scan-assembler-times {\mvextsw2d\M} 1 } } */ diff --git a/gcc/testsuite/gcc.target/powerpc/pr101985-1.c b/gcc/testsuite/gcc.target/powerpc/pr101985-1.c new file mode 100644 index 0000000..b4753ab --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/pr101985-1.c @@ -0,0 +1,18 @@ +/* PR target/101985 */ +/* { dg-do run } */ +/* { dg-require-effective-target vsx_hw } */ +/* { dg-options "-O2 -mvsx" } */ + +#include <altivec.h> + +int +main (void) +{ + vector float a = { 1, 2, - 3, - 4}; + vector float b = {-10, 20, -30, 40}; + vector float c = { 10, 20, -30, -40}; + a = vec_cpsgn (a, b); + if (! vec_all_eq (a, c)) + __builtin_abort (); + return 0; +} diff --git a/gcc/testsuite/gcc.target/powerpc/pr101985-2.c b/gcc/testsuite/gcc.target/powerpc/pr101985-2.c new file mode 100644 index 0000000..435d3a9 --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/pr101985-2.c @@ -0,0 +1,18 @@ +/* PR target/101985 */ +/* { dg-do run } */ +/* { dg-require-effective-target vsx_hw } */ +/* { dg-options "-O2 -mvsx" } */ + +#include <altivec.h> + +int +main (void) +{ + vector double a = { 1, -4}; + vector double b = { -10, 40}; + vector double c = { 10, -40}; + a = vec_cpsgn (a, b); + if (! vec_all_eq (a, c)) + __builtin_abort (); + return 0; +} diff --git a/gcc/testsuite/gcc.target/powerpc/pr78102.c b/gcc/testsuite/gcc.target/powerpc/pr78102.c new file mode 100644 index 0000000..0b50910 --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/pr78102.c @@ -0,0 +1,23 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -mdejagnu-cpu=power8 -DNO_WARN_X86_INTRINSICS" } */ +/* { dg-require-effective-target powerpc_p8vector_ok } */ + +#include <x86intrin.h> + +__m128i +foo (const __m128i x, const __m128i y) +{ + return _mm_cmpeq_epi64 (x, y); +} + +__v2di +bar (const __v2di x, const __v2di y) +{ + return x == y; +} + +__v2di +baz (const __v2di x, const __v2di y) +{ + return x != y; +} diff --git a/gcc/testsuite/gcc.target/powerpc/pr80510-2.c b/gcc/testsuite/gcc.target/powerpc/pr80510-2.c index f85e005..d041d96 100644 --- a/gcc/testsuite/gcc.target/powerpc/pr80510-2.c +++ b/gcc/testsuite/gcc.target/powerpc/pr80510-2.c @@ -1,7 +1,9 @@ /* { dg-do compile { target { powerpc*-*-* } } } */ /* { dg-skip-if "" { powerpc*-*-darwin* } } */ /* { dg-require-effective-target powerpc_p8vector_ok } */ -/* { dg-options "-mdejagnu-cpu=power8 -O2" } */ +/* Now O2 enables vectorization by default, which generates unexpected VSR + to GPR movement for vector construction, so simply disable it. */ +/* { dg-options "-mdejagnu-cpu=power8 -O2 -fno-tree-vectorize" } */ /* Make sure that STXSSPX is generated for float scalars in Altivec registers on power7 instead of moving the value to a FPR register and doing a X-FORM diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-packusdw.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-packusdw.c new file mode 100644 index 0000000..fe51003 --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-packusdw.c @@ -0,0 +1,73 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -mvsx" } */ +/* { dg-require-effective-target vsx_hw } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_1-check.h" +#endif + +#ifndef TEST +#define TEST sse4_1_test +#endif + +#include CHECK_H + +#include <smmintrin.h> + +#define NUM 64 + +static unsigned short +int_to_ushort (int iVal) +{ + unsigned short sVal; + + if (iVal < 0) + sVal = 0; + else if (iVal > 0xffff) + sVal = 0xffff; + else sVal = iVal; + + return sVal; +} + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 4]; + int i[NUM]; + } src1, src2; + union + { + __m128i x[NUM / 4]; + unsigned short s[NUM * 2]; + } dst; + int i, sign = 1; + + for (i = 0; i < NUM; i++) + { + src1.i[i] = i * i * sign; + src2.i[i] = (i + 20) * sign; + sign = -sign; + } + + for (i = 0; i < NUM; i += 4) + dst.x[i / 4] = _mm_packus_epi32 (src1.x [i / 4], src2.x [i / 4]); + + for (i = 0; i < NUM; i ++) + { + int dstIndex; + unsigned short sVal; + + sVal = int_to_ushort (src1.i[i]); + dstIndex = (i % 4) + (i / 4) * 8; + if (sVal != dst.s[dstIndex]) + abort (); + + sVal = int_to_ushort (src2.i[i]); + dstIndex += 4; + if (sVal != dst.s[dstIndex]) + abort (); + } +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-pcmpeqq.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-pcmpeqq.c new file mode 100644 index 0000000..39b9f01 --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-pcmpeqq.c @@ -0,0 +1,46 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -mpower8-vector" } */ +/* { dg-require-effective-target p8vector_hw } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_1-check.h" +#endif + +#ifndef TEST +#define TEST sse4_1_test +#endif + +#include CHECK_H + +#include <smmintrin.h> + +#define NUM 64 + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 2]; + long long ll[NUM]; + } dst, src1, src2; + int i, sign=1; + long long is_eq; + + for (i = 0; i < NUM; i++) + { + src1.ll[i] = i * i * sign; + src2.ll[i] = (i + 20) * sign; + sign = -sign; + } + + for (i = 0; i < NUM; i += 2) + dst.x [i / 2] = _mm_cmpeq_epi64(src1.x [i / 2], src2.x [i / 2]); + + for (i = 0; i < NUM; i++) + { + is_eq = src1.ll[i] == src2.ll[i] ? 0xffffffffffffffffLL : 0LL; + if (is_eq != dst.ll[i]) + abort (); + } +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-phminposuw.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-phminposuw.c index 146df24..150a8a0 100644 --- a/gcc/testsuite/gcc.target/powerpc/sse4_1-phminposuw.c +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-phminposuw.c @@ -1,6 +1,6 @@ /* { dg-do run } */ /* { dg-options "-O2 -mvsx -Wno-psabi" } */ -/* { dg-require-effective-target powerpc_vsx_ok } */ +/* { dg-require-effective-target vsx_hw } */ #define NO_WARN_X86_INTRINSICS 1 #ifndef CHECK_H diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-pmaxsb.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmaxsb.c new file mode 100644 index 0000000..2f5906d --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmaxsb.c @@ -0,0 +1,46 @@ +/* { dg-do run } */ +/* { dg-require-effective-target vsx_hw } */ +/* { dg-options "-O2 -mvsx" } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_1-check.h" +#endif + +#ifndef TEST +#define TEST sse4_1_test +#endif + +#include CHECK_H + +#include <smmintrin.h> + +#define NUM 1024 + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 16]; + signed char i[NUM]; + } dst, src1, src2; + int i, sign = 1; + signed char max; + + for (i = 0; i < NUM; i++) + { + src1.i[i] = i * i * sign; + src2.i[i] = (i + 20) * sign; + sign = -sign; + } + + for (i = 0; i < NUM; i += 16) + dst.x[i / 16] = _mm_max_epi8 (src1.x[i / 16], src2.x[i / 16]); + + for (i = 0; i < NUM; i++) + { + max = src1.i[i] <= src2.i[i] ? src2.i[i] : src1.i[i]; + if (max != dst.i[i]) + abort (); + } +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-pmaxsd.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmaxsd.c new file mode 100644 index 0000000..d196abe --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmaxsd.c @@ -0,0 +1,46 @@ +/* { dg-do run } */ +/* { dg-require-effective-target vsx_hw } */ +/* { dg-options "-O2 -mvsx" } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_1-check.h" +#endif + +#ifndef TEST +#define TEST sse4_1_test +#endif + +#include CHECK_H + +#include <smmintrin.h> + +#define NUM 64 + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 4]; + int i[NUM]; + } dst, src1, src2; + int i, sign = 1; + int max; + + for (i = 0; i < NUM; i++) + { + src1.i[i] = i * i * sign; + src2.i[i] = (i + 20) * sign; + sign = -sign; + } + + for (i = 0; i < NUM; i += 4) + dst.x[i / 4] = _mm_max_epi32 (src1.x[i / 4], src2.x[i / 4]); + + for (i = 0; i < NUM; i++) + { + max = src1.i[i] <= src2.i[i] ? src2.i[i] : src1.i[i]; + if (max != dst.i[i]) + abort (); + } +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-pmaxud.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmaxud.c new file mode 100644 index 0000000..140a7f8 --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmaxud.c @@ -0,0 +1,47 @@ +/* { dg-do run } */ +/* { dg-require-effective-target vsx_hw } */ +/* { dg-options "-O2 -mvsx" } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_1-check.h" +#endif + +#ifndef TEST +#define TEST sse4_1_test +#endif + +#include CHECK_H + +#include <smmintrin.h> + +#define NUM 64 + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 4]; + unsigned int i[NUM]; + } dst, src1, src2; + int i; + unsigned int max; + + for (i = 0; i < NUM; i++) + { + src1.i[i] = i * i; + src2.i[i] = i + 20; + if ((i % 4)) + src2.i[i] |= 0x80000000; + } + + for (i = 0; i < NUM; i += 4) + dst.x[i / 4] = _mm_max_epu32 (src1.x[i / 4], src2.x[i / 4]); + + for (i = 0; i < NUM; i++) + { + max = src1.i[i] <= src2.i[i] ? src2.i[i] : src1.i[i]; + if (max != dst.i[i]) + abort (); + } +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-pmaxuw.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmaxuw.c new file mode 100644 index 0000000..9f9b05f --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmaxuw.c @@ -0,0 +1,47 @@ +/* { dg-do run } */ +/* { dg-require-effective-target vsx_hw } */ +/* { dg-options "-O2 -mvsx" } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_1-check.h" +#endif + +#ifndef TEST +#define TEST sse4_1_test +#endif + +#include CHECK_H + +#include <smmintrin.h> + +#define NUM 64 + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 8]; + unsigned short i[NUM]; + } dst, src1, src2; + int i; + unsigned short max; + + for (i = 0; i < NUM; i++) + { + src1.i[i] = i * i; + src2.i[i] = i + 20; + if ((i % 8)) + src2.i[i] |= 0x8000; + } + + for (i = 0; i < NUM; i += 8) + dst.x[i / 8] = _mm_max_epu16 (src1.x[i / 8], src2.x[i / 8]); + + for (i = 0; i < NUM; i++) + { + max = src1.i[i] <= src2.i[i] ? src2.i[i] : src1.i[i]; + if (max != dst.i[i]) + abort (); + } +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-pminsb.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-pminsb.c new file mode 100644 index 0000000..533e2bc --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-pminsb.c @@ -0,0 +1,46 @@ +/* { dg-do run } */ +/* { dg-require-effective-target vsx_hw } */ +/* { dg-options "-O2 -mvsx" } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_1-check.h" +#endif + +#ifndef TEST +#define TEST sse4_1_test +#endif + +#include CHECK_H + +#include <smmintrin.h> + +#define NUM 1024 + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 16]; + signed char i[NUM]; + } dst, src1, src2; + int i, sign = 1; + signed char min; + + for (i = 0; i < NUM; i++) + { + src1.i[i] = i * i * sign; + src2.i[i] = (i + 20) * sign; + sign = -sign; + } + + for (i = 0; i < NUM; i += 16) + dst.x[i / 16] = _mm_min_epi8 (src1.x[i / 16], src2.x[i / 16]); + + for (i = 0; i < NUM; i++) + { + min = src1.i[i] >= src2.i[i] ? src2.i[i] : src1.i[i]; + if (min != dst.i[i]) + abort (); + } +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-pminsd.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-pminsd.c new file mode 100644 index 0000000..585a2ac --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-pminsd.c @@ -0,0 +1,46 @@ +/* { dg-do run } */ +/* { dg-require-effective-target vsx_hw } */ +/* { dg-options "-O2 -mvsx" } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_1-check.h" +#endif + +#ifndef TEST +#define TEST sse4_1_test +#endif + +#include CHECK_H + +#include <smmintrin.h> + +#define NUM 64 + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 4]; + int i[NUM]; + } dst, src1, src2; + int i, sign = 1; + int min; + + for (i = 0; i < NUM; i++) + { + src1.i[i] = i * i * sign; + src2.i[i] = (i + 20) * sign; + sign = -sign; + } + + for (i = 0; i < NUM; i += 4) + dst.x[i / 4] = _mm_min_epi32 (src1.x[i / 4], src2.x[i / 4]); + + for (i = 0; i < NUM; i++) + { + min = src1.i[i] >= src2.i[i] ? src2.i[i] : src1.i[i]; + if (min != dst.i[i]) + abort (); + } +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-pminud.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-pminud.c new file mode 100644 index 0000000..bd6b46f --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-pminud.c @@ -0,0 +1,47 @@ +/* { dg-do run } */ +/* { dg-require-effective-target vsx_hw } */ +/* { dg-options "-O2 -mvsx" } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_1-check.h" +#endif + +#ifndef TEST +#define TEST sse4_1_test +#endif + +#include CHECK_H + +#include <smmintrin.h> + +#define NUM 64 + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 4]; + unsigned int i[NUM]; + } dst, src1, src2; + int i; + unsigned int min; + + for (i = 0; i < NUM; i++) + { + src1.i[i] = i * i; + src2.i[i] = i + 20; + if ((i % 4)) + src2.i[i] |= 0x80000000; + } + + for (i = 0; i < NUM; i += 4) + dst.x[i / 4] = _mm_min_epu32 (src1.x[i / 4], src2.x[i / 4]); + + for (i = 0; i < NUM; i++) + { + min = src1.i[i] >= src2.i[i] ? src2.i[i] : src1.i[i]; + if (min != dst.i[i]) + abort (); + } +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-pminuw.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-pminuw.c new file mode 100644 index 0000000..b4ef717 --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-pminuw.c @@ -0,0 +1,47 @@ +/* { dg-do run } */ +/* { dg-require-effective-target vsx_hw } */ +/* { dg-options "-O2 -mvsx" } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_1-check.h" +#endif + +#ifndef TEST +#define TEST sse4_1_test +#endif + +#include CHECK_H + +#include <smmintrin.h> + +#define NUM 64 + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 8]; + unsigned short i[NUM]; + } dst, src1, src2; + int i; + unsigned short min; + + for (i = 0; i < NUM; i++) + { + src1.i[i] = i * i; + src2.i[i] = i + 20; + if ((i % 8)) + src2.i[i] |= 0x8000; + } + + for (i = 0; i < NUM; i += 8) + dst.x[i / 8] = _mm_min_epu16 (src1.x[i / 8], src2.x[i / 8]); + + for (i = 0; i < NUM; i++) + { + min = src1.i[i] >= src2.i[i] ? src2.i[i] : src1.i[i]; + if (min != dst.i[i]) + abort (); + } +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovsxbd.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovsxbd.c new file mode 100644 index 0000000..f3021da --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovsxbd.c @@ -0,0 +1,42 @@ +/* { dg-do run } */ +/* { dg-require-effective-target vsx_hw } */ +/* { dg-options "-O2 -mvsx" } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_1-check.h" +#endif + +#ifndef TEST +#define TEST sse4_1_test +#endif + +#include CHECK_H + +#include <smmintrin.h> + +#define NUM 128 + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 4]; + int i[NUM]; + signed char c[NUM * 4]; + } dst, src; + int i, sign = 1; + + for (i = 0; i < NUM; i++) + { + src.c[(i % 4) + (i / 4) * 16] = i * i * sign; + sign = -sign; + } + + for (i = 0; i < NUM; i += 4) + dst.x [i / 4] = _mm_cvtepi8_epi32 (src.x [i / 4]); + + for (i = 0; i < NUM; i++) + if (src.c[(i % 4) + (i / 4) * 16] != dst.i[i]) + abort (); +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovsxbq.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovsxbq.c new file mode 100644 index 0000000..9ec1ab7 --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovsxbq.c @@ -0,0 +1,42 @@ +/* { dg-do run } */ +/* { dg-require-effective-target p8vector_hw } */ +/* { dg-options "-O2 -mpower8-vector" } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_1-check.h" +#endif + +#ifndef TEST +#define TEST sse4_1_test +#endif + +#include CHECK_H + +#include <smmintrin.h> + +#define NUM 128 + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 2]; + long long ll[NUM]; + signed char c[NUM * 8]; + } dst, src; + int i, sign = 1; + + for (i = 0; i < NUM; i++) + { + src.c[(i % 2) + (i / 2) * 16] = i * i * sign; + sign = -sign; + } + + for (i = 0; i < NUM; i += 2) + dst.x [i / 2] = _mm_cvtepi8_epi64 (src.x [i / 2]); + + for (i = 0; i < NUM; i++) + if (src.c[(i % 2) + (i / 2) * 16] != dst.ll[i]) + abort (); +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovsxbw.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovsxbw.c new file mode 100644 index 0000000..dabd6bc --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovsxbw.c @@ -0,0 +1,42 @@ +/* { dg-do run } */ +/* { dg-require-effective-target vsx_hw } */ +/* { dg-options "-O2 -mvsx" } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_1-check.h" +#endif + +#ifndef TEST +#define TEST sse4_1_test +#endif + +#include CHECK_H + +#include <smmintrin.h> + +#define NUM 128 + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 8]; + short s[NUM]; + signed char c[NUM * 2]; + } dst, src; + int i, sign = 1; + + for (i = 0; i < NUM; i++) + { + src.c[(i % 8) + (i / 8) * 16] = i * i * sign; + sign = -sign; + } + + for (i = 0; i < NUM; i += 8) + dst.x [i / 8] = _mm_cvtepi8_epi16 (src.x [i / 8]); + + for (i = 0; i < NUM; i++) + if (src.c[(i % 8) + (i / 8) * 16] != dst.s[i]) + abort (); +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovsxdq.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovsxdq.c new file mode 100644 index 0000000..1c26378 --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovsxdq.c @@ -0,0 +1,42 @@ +/* { dg-do run } */ +/* { dg-require-effective-target p8vector_hw } */ +/* { dg-options "-O2 -mpower8-vector" } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_1-check.h" +#endif + +#ifndef TEST +#define TEST sse4_1_test +#endif + +#include CHECK_H + +#include <smmintrin.h> + +#define NUM 128 + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 2]; + long long ll[NUM]; + int i[NUM * 2]; + } dst, src; + int i, sign = 1; + + for (i = 0; i < NUM; i++) + { + src.i[(i % 2) + (i / 2) * 4] = i * i * sign; + sign = -sign; + } + + for (i = 0; i < NUM; i += 2) + dst.x [i / 2] = _mm_cvtepi32_epi64 (src.x [i / 2]); + + for (i = 0; i < NUM; i++) + if (src.i[(i % 2) + (i / 2) * 4] != dst.ll[i]) + abort (); +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovsxwd.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovsxwd.c new file mode 100644 index 0000000..e698f28 --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovsxwd.c @@ -0,0 +1,42 @@ +/* { dg-do run } */ +/* { dg-require-effective-target vsx_hw } */ +/* { dg-options "-O2 -mvsx" } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_1-check.h" +#endif + +#ifndef TEST +#define TEST sse4_1_test +#endif + +#include CHECK_H + +#include <smmintrin.h> + +#define NUM 128 + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 4]; + int i[NUM]; + short s[NUM * 2]; + } dst, src; + int i, sign = 1; + + for (i = 0; i < NUM; i++) + { + src.s[(i % 4) + (i / 4) * 8] = i * i * sign; + sign = -sign; + } + + for (i = 0; i < NUM; i += 4) + dst.x [i / 4] = _mm_cvtepi16_epi32 (src.x [i / 4]); + + for (i = 0; i < NUM; i++) + if (src.s[(i % 4) + (i / 4) * 8] != dst.i[i]) + abort (); +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovsxwq.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovsxwq.c new file mode 100644 index 0000000..6786469 --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovsxwq.c @@ -0,0 +1,42 @@ +/* { dg-do run } */ +/* { dg-require-effective-target p8vector_hw } */ +/* { dg-options "-O2 -mpower8-vector" } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_1-check.h" +#endif + +#ifndef TEST +#define TEST sse4_1_test +#endif + +#include CHECK_H + +#include <smmintrin.h> + +#define NUM 128 + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 2]; + long long ll[NUM]; + short s[NUM * 4]; + } dst, src; + int i, sign = 1; + + for (i = 0; i < NUM; i++) + { + src.s[(i % 2) + (i / 2) * 8] = i * i * sign; + sign = -sign; + } + + for (i = 0; i < NUM; i += 2) + dst.x [i / 2] = _mm_cvtepi16_epi64 (src.x [i / 2]); + + for (i = 0; i < NUM; i++) + if (src.s[(i % 2) + (i / 2) * 8] != dst.ll[i]) + abort (); +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovzxbd.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovzxbd.c new file mode 100644 index 0000000..f902ca1 --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovzxbd.c @@ -0,0 +1,43 @@ +/* { dg-do run } */ +/* { dg-require-effective-target vsx_hw } */ +/* { dg-options "-O2 -mvsx" } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_1-check.h" +#endif + +#ifndef TEST +#define TEST sse4_1_test +#endif + +#include CHECK_H + +#include <smmintrin.h> + +#define NUM 128 + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 4]; + unsigned int i[NUM]; + unsigned char c[NUM * 4]; + } dst, src; + int i; + + for (i = 0; i < NUM; i++) + { + src.c[(i % 4) + (i / 4) * 16] = i * i; + if ((i % 4)) + src.c[(i % 4) + (i / 4) * 16] |= 0x80; + } + + for (i = 0; i < NUM; i += 4) + dst.x [i / 4] = _mm_cvtepu8_epi32 (src.x [i / 4]); + + for (i = 0; i < NUM; i++) + if (src.c[(i % 4) + (i / 4) * 16] != dst.i[i]) + abort (); +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovzxbq.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovzxbq.c new file mode 100644 index 0000000..1dbe126 --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovzxbq.c @@ -0,0 +1,43 @@ +/* { dg-do run } */ +/* { dg-require-effective-target vsx_hw } */ +/* { dg-options "-O2 -mvsx" } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_1-check.h" +#endif + +#ifndef TEST +#define TEST sse4_1_test +#endif + +#include CHECK_H + +#include <smmintrin.h> + +#define NUM 128 + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 2]; + unsigned long long ll[NUM]; + unsigned char c[NUM * 8]; + } dst, src; + int i; + + for (i = 0; i < NUM; i++) + { + src.c[(i % 2) + (i / 2) * 16] = i * i; + if ((i % 2)) + src.c[(i % 2) + (i / 2) * 16] |= 0x80; + } + + for (i = 0; i < NUM; i += 2) + dst.x [i / 2] = _mm_cvtepu8_epi64 (src.x [i / 2]); + + for (i = 0; i < NUM; i++) + if (src.c[(i % 2) + (i / 2) * 16] != dst.ll[i]) + abort (); +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovzxbw.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovzxbw.c new file mode 100644 index 0000000..8be531f --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovzxbw.c @@ -0,0 +1,43 @@ +/* { dg-do run } */ +/* { dg-require-effective-target vsx_hw } */ +/* { dg-options "-O2 -mvsx" } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_1-check.h" +#endif + +#ifndef TEST +#define TEST sse4_1_test +#endif + +#include CHECK_H + +#include <smmintrin.h> + +#define NUM 128 + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 8]; + unsigned short s[NUM]; + unsigned char c[NUM * 2]; + } dst, src; + int i; + + for (i = 0; i < NUM; i++) + { + src.c[(i % 8) + (i / 8) * 16] = i * i; + if ((i % 4)) + src.c[(i % 8) + (i / 8) * 16] |= 0x80; + } + + for (i = 0; i < NUM; i += 8) + dst.x [i / 8] = _mm_cvtepu8_epi16 (src.x [i / 8]); + + for (i = 0; i < NUM; i++) + if (src.c[(i % 8) + (i / 8) * 16] != dst.s[i]) + abort (); +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovzxdq.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovzxdq.c new file mode 100644 index 0000000..8154407 --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovzxdq.c @@ -0,0 +1,43 @@ +/* { dg-do run } */ +/* { dg-require-effective-target vsx_hw } */ +/* { dg-options "-O2 -mvsx" } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_1-check.h" +#endif + +#ifndef TEST +#define TEST sse4_1_test +#endif + +#include CHECK_H + +#include <smmintrin.h> + +#define NUM 128 + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 2]; + unsigned long long ll[NUM]; + unsigned int i[NUM * 2]; + } dst, src; + int i; + + for (i = 0; i < NUM; i++) + { + src.i[(i % 2) + (i / 2) * 4] = i * i; + if ((i % 2)) + src.i[(i % 2) + (i / 2) * 4] |= 0x80000000; + } + + for (i = 0; i < NUM; i += 2) + dst.x [i / 2] = _mm_cvtepu32_epi64 (src.x [i / 2]); + + for (i = 0; i < NUM; i++) + if (src.i[(i % 2) + (i / 2) * 4] != dst.ll[i]) + abort (); +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovzxwd.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovzxwd.c new file mode 100644 index 0000000..77c797b --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovzxwd.c @@ -0,0 +1,43 @@ +/* { dg-do run } */ +/* { dg-require-effective-target vsx_hw } */ +/* { dg-options "-O2 -mvsx" } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_1-check.h" +#endif + +#ifndef TEST +#define TEST sse4_1_test +#endif + +#include CHECK_H + +#include <smmintrin.h> + +#define NUM 128 + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 4]; + unsigned int i[NUM]; + unsigned short s[NUM * 2]; + } dst, src; + int i; + + for (i = 0; i < NUM; i++) + { + src.s[(i % 4) + (i / 4) * 8] = i * i; + if ((i % 4)) + src.s[(i % 4) + (i / 4) * 8] |= 0x8000; + } + + for (i = 0; i < NUM; i += 4) + dst.x [i / 4] = _mm_cvtepu16_epi32 (src.x [i / 4]); + + for (i = 0; i < NUM; i++) + if (src.s[(i % 4) + (i / 4) * 8] != dst.i[i]) + abort (); +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovzxwq.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovzxwq.c new file mode 100644 index 0000000..999542d --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmovzxwq.c @@ -0,0 +1,43 @@ +/* { dg-do run } */ +/* { dg-require-effective-target vsx_hw } */ +/* { dg-options "-O2 -mvsx" } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_1-check.h" +#endif + +#ifndef TEST +#define TEST sse4_1_test +#endif + +#include CHECK_H + +#include <smmintrin.h> + +#define NUM 128 + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 2]; + unsigned long long ll[NUM]; + unsigned short s[NUM * 4]; + } dst, src; + int i; + + for (i = 0; i < NUM; i++) + { + src.s[(i % 2) + (i / 2) * 8] = i * i; + if ((i % 2)) + src.s[(i % 2) + (i / 2) * 8] |= 0x8000; + } + + for (i = 0; i < NUM; i += 2) + dst.x [i / 2] = _mm_cvtepu16_epi64 (src.x [i / 2]); + + for (i = 0; i < NUM; i++) + if (src.s[(i % 2) + (i / 2) * 8] != dst.ll[i]) + abort (); +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-pmuldq.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmuldq.c new file mode 100644 index 0000000..6a884f4 --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmuldq.c @@ -0,0 +1,51 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -mpower8-vector" } */ +/* { dg-require-effective-target p8vector_hw } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_1-check.h" +#endif + +#ifndef TEST +#define TEST sse4_1_test +#endif + +#include CHECK_H + +#include <smmintrin.h> + +#define NUM 64 + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 2]; + long long ll[NUM]; + } dst; + union + { + __m128i x[NUM / 2]; + int i[NUM * 2]; + } src1, src2; + int i, sign = 1; + long long value; + + for (i = 0; i < NUM * 2; i += 2) + { + src1.i[i] = i * i * sign; + src2.i[i] = (i + 20) * sign; + sign = -sign; + } + + for (i = 0; i < NUM; i += 2) + dst.x[i / 2] = _mm_mul_epi32 (src1.x[i / 2], src2.x[i / 2]); + + for (i = 0; i < NUM; i++) + { + value = (long long) src1.i[i * 2] * (long long) src2.i[i * 2]; + if (value != dst.ll[i]) + abort (); + } +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_1-pmulld.c b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmulld.c new file mode 100644 index 0000000..43eda16 --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_1-pmulld.c @@ -0,0 +1,46 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -mvsx" } */ +/* { dg-require-effective-target vsx_hw } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_1-check.h" +#endif + +#ifndef TEST +#define TEST sse4_1_test +#endif + +#include CHECK_H + +#include <smmintrin.h> + +#define NUM 64 + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 4]; + int i[NUM]; + } dst, src1, src2; + int i, sign = 1; + int value; + + for (i = 0; i < NUM; i++) + { + src1.i[i] = i * i * sign; + src2.i[i] = (i + 20) * sign; + sign = -sign; + } + + for (i = 0; i < NUM; i += 4) + dst.x[i / 4] = _mm_mullo_epi32 (src1.x[i / 4], src2.x[i / 4]); + + for (i = 0; i < NUM; i++) + { + value = src1.i[i] * src2.i[i]; + if (value != dst.i[i]) + abort (); + } +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_2-check.h b/gcc/testsuite/gcc.target/powerpc/sse4_2-check.h new file mode 100644 index 0000000..f6264e5 --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_2-check.h @@ -0,0 +1,18 @@ +#define NO_WARN_X86_INTRINSICS 1 + +static void sse4_2_test (void); + +static void +__attribute__ ((noinline)) +do_test (void) +{ + sse4_2_test (); +} + +int +main () +{ + do_test (); + + return 0; +} diff --git a/gcc/testsuite/gcc.target/powerpc/sse4_2-pcmpgtq.c b/gcc/testsuite/gcc.target/powerpc/sse4_2-pcmpgtq.c new file mode 100644 index 0000000..36b9bd7 --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/sse4_2-pcmpgtq.c @@ -0,0 +1,46 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -mpower8-vector" } */ +/* { dg-require-effective-target p8vector_hw } */ + +#ifndef CHECK_H +#define CHECK_H "sse4_2-check.h" +#endif + +#ifndef TEST +#define TEST sse4_2_test +#endif + +#include CHECK_H + +#include <nmmintrin.h> + +#define NUM 64 + +static void +TEST (void) +{ + union + { + __m128i x[NUM / 2]; + long long ll[NUM]; + } dst, src1, src2; + int i, sign = 1; + long long is_eq; + + for (i = 0; i < NUM; i++) + { + src1.ll[i] = i * i * sign; + src2.ll[i] = (i + 20) * sign; + sign = -sign; + } + + for (i = 0; i < NUM; i += 2) + dst.x[i / 2] = _mm_cmpgt_epi64 (src1.x[i / 2], src2.x[i / 2]); + + for (i = 0; i < NUM; i++) + { + is_eq = src1.ll[i] > src2.ll[i] ? 0xFFFFFFFFFFFFFFFFLL : 0LL; + if (is_eq != dst.ll[i]) + abort (); + } +} diff --git a/gcc/testsuite/gcc.target/powerpc/unwind-backchain.c b/gcc/testsuite/gcc.target/powerpc/unwind-backchain.c new file mode 100644 index 0000000..affa9b2 --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/unwind-backchain.c @@ -0,0 +1,24 @@ +/* -linux* targets have a fallback for the absence of unwind tables, thus are + the only ones we can guarantee backtrace returns all addresses. */ +/* { dg-do run { target { *-*-linux* } } } */ +/* { dg-options "-fno-asynchronous-unwind-tables" } */ + +#include <execinfo.h> + +void +test_backtrace() +{ + int addresses; + void *buffer[10]; + + addresses = backtrace(buffer, 10); + if(addresses != 4) + __builtin_abort(); +} + +int +main() +{ + test_backtrace(); + return 0; +} diff --git a/gcc/testsuite/gcc.target/riscv/zba-adduw.c b/gcc/testsuite/gcc.target/riscv/zba-adduw.c new file mode 100644 index 0000000..cac1e84 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/zba-adduw.c @@ -0,0 +1,12 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gc_zba_zbs -mabi=lp64 -O2" } */ + +int foo(int n, unsigned char *arr, unsigned y){ + int s = 0; + unsigned x = 0; + for (;x<n;x++) + s += arr[x+y]; + return s; +} + +/* { dg-final { scan-assembler "add.uw" } } */ diff --git a/gcc/testsuite/gcc.target/riscv/zba-shNadd-01.c b/gcc/testsuite/gcc.target/riscv/zba-shNadd-01.c new file mode 100644 index 0000000..aaabaf5 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/zba-shNadd-01.c @@ -0,0 +1,19 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gc_zba -mabi=lp64 -O2" } */ + +long test_1(long a, long b) +{ + return a + (b << 1); +} +long test_2(long a, long b) +{ + return a + (b << 2); +} +long test_3(long a, long b) +{ + return a + (b << 3); +} + +/* { dg-final { scan-assembler-times "sh1add" 1 } } */ +/* { dg-final { scan-assembler-times "sh2add" 1 } } */ +/* { dg-final { scan-assembler-times "sh3add" 1 } } */ diff --git a/gcc/testsuite/gcc.target/riscv/zba-shNadd-02.c b/gcc/testsuite/gcc.target/riscv/zba-shNadd-02.c new file mode 100644 index 0000000..8dfea4a --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/zba-shNadd-02.c @@ -0,0 +1,19 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv32gc_zba -mabi=ilp32 -O2" } */ + +long test_1(long a, long b) +{ + return a + (b << 1); +} +long test_2(long a, long b) +{ + return a + (b << 2); +} +long test_3(long a, long b) +{ + return a + (b << 3); +} + +/* { dg-final { scan-assembler-times "sh1add" 1 } } */ +/* { dg-final { scan-assembler-times "sh2add" 1 } } */ +/* { dg-final { scan-assembler-times "sh3add" 1 } } */ diff --git a/gcc/testsuite/gcc.target/riscv/zba-shNadd-03.c b/gcc/testsuite/gcc.target/riscv/zba-shNadd-03.c new file mode 100644 index 0000000..b2ea231 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/zba-shNadd-03.c @@ -0,0 +1,31 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gc_zba -mabi=lp64 -O2" } */ + +/* RV64 only. */ +int foos(short *x, int n){ + return x[n]; +} +int fooi(int *x, int n){ + return x[n]; +} +int fooll(long long *x, int n){ + return x[n]; +} + +/* RV64 only. */ +int ufoos(short *x, unsigned int n){ + return x[n]; +} +int ufooi(int *x, unsigned int n){ + return x[n]; +} +int ufooll(long long *x, unsigned int n){ + return x[n]; +} + +/* { dg-final { scan-assembler-times "sh1add\t" 1 } } */ +/* { dg-final { scan-assembler-times "sh2add\t" 1 } } */ +/* { dg-final { scan-assembler-times "sh3add\t" 1 } } */ +/* { dg-final { scan-assembler-times "sh3add.uw" 1 } } */ +/* { dg-final { scan-assembler-times "sh3add.uw" 1 } } */ +/* { dg-final { scan-assembler-times "sh3add.uw" 1 } } */ diff --git a/gcc/testsuite/gcc.target/riscv/zba-slliuw.c b/gcc/testsuite/gcc.target/riscv/zba-slliuw.c new file mode 100644 index 0000000..a7a3dc7 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/zba-slliuw.c @@ -0,0 +1,11 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gc_zba_zbs -mabi=lp64 -O2" } */ + +long +foo (long i) +{ + return (long)(unsigned int)i << 10; +} +/* XXX: This pattern need combine improvement or intermediate instruction + * from zbs. */ +/* { dg-final { scan-assembler "slli.uw" } } */ diff --git a/gcc/testsuite/gcc.target/riscv/zba-zextw.c b/gcc/testsuite/gcc.target/riscv/zba-zextw.c new file mode 100644 index 0000000..26fd64d --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/zba-zextw.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gc_zba_zbs -mabi=lp64 -O2" } */ + +long +foo (long i) +{ + return (long)(unsigned int)i; +} +/* XXX: This pattern require combine improvement. */ +/* { dg-final { scan-assembler-not "slli.uw" } } */ diff --git a/gcc/testsuite/gcc.target/riscv/zbb-andn-orn-xnor-01.c b/gcc/testsuite/gcc.target/riscv/zbb-andn-orn-xnor-01.c new file mode 100644 index 0000000..0037dea --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/zbb-andn-orn-xnor-01.c @@ -0,0 +1,21 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gc_zbb -mabi=lp64 -O2" } */ + +unsigned long long foo1(unsigned long long rs1, unsigned long long rs2) +{ +return rs1 & ~rs2; +} + +unsigned long long foo2(unsigned long long rs1, unsigned long long rs2) +{ +return rs1 | ~rs2; +} + +unsigned long long foo3(unsigned long long rs1, unsigned long long rs2) +{ +return rs1 ^ ~rs2; +} + +/* { dg-final { scan-assembler-times "andn" 2 } } */ +/* { dg-final { scan-assembler-times "orn" 2 } } */ +/* { dg-final { scan-assembler-times "xnor" 2 } } */
\ No newline at end of file diff --git a/gcc/testsuite/gcc.target/riscv/zbb-andn-orn-xnor-02.c b/gcc/testsuite/gcc.target/riscv/zbb-andn-orn-xnor-02.c new file mode 100644 index 0000000..b0c1e40 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/zbb-andn-orn-xnor-02.c @@ -0,0 +1,21 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv32gc_zbb -mabi=ilp32 -O2" } */ + +unsigned int foo1(unsigned int rs1, unsigned int rs2) +{ +return rs1 & ~rs2; +} + +unsigned int foo2(unsigned int rs1, unsigned int rs2) +{ +return rs1 | ~rs2; +} + +unsigned int foo3(unsigned int rs1, unsigned int rs2) +{ +return rs1 ^ ~rs2; +} + +/* { dg-final { scan-assembler-times "andn" 2 } } */ +/* { dg-final { scan-assembler-times "orn" 2 } } */ +/* { dg-final { scan-assembler-times "xnor" 2 } } */
\ No newline at end of file diff --git a/gcc/testsuite/gcc.target/riscv/zbb-li-rotr.c b/gcc/testsuite/gcc.target/riscv/zbb-li-rotr.c new file mode 100644 index 0000000..03254ed --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/zbb-li-rotr.c @@ -0,0 +1,35 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gc_zbb -mabi=lp64 -O2" } */ + +long +li_rori (void) +{ + return 0xffff77ffffffffffL; +} + +long +li_rori_2 (void) +{ + return 0x77ffffffffffffffL; +} + +long +li_rori_3 (void) +{ + return 0xfffffffeefffffffL; +} + +long +li_rori_4 (void) +{ + return 0x5ffffffffffffff5L; +} + +long +li_rori_5 (void) +{ + return 0xaffffffffffffffaL; +} + + +/* { dg-final { scan-assembler-times "rori\t" 5 } } */ diff --git a/gcc/testsuite/gcc.target/riscv/zbb-min-max.c b/gcc/testsuite/gcc.target/riscv/zbb-min-max.c new file mode 100644 index 0000000..f44c398 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/zbb-min-max.c @@ -0,0 +1,31 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gc_zbb -mabi=lp64 -O2" } */ + +long +foo1 (long i, long j) +{ + return i < j ? i : j; +} + +long +foo2 (long i, long j) +{ + return i > j ? i : j; +} + +unsigned long +foo3 (unsigned long i, unsigned long j) +{ + return i < j ? i : j; +} + +unsigned long +foo4 (unsigned long i, unsigned long j) +{ + return i > j ? i : j; +} + +/* { dg-final { scan-assembler-times "min" 3 } } */ +/* { dg-final { scan-assembler-times "max" 3 } } */ +/* { dg-final { scan-assembler-times "minu" 1 } } */ +/* { dg-final { scan-assembler-times "maxu" 1 } } */ diff --git a/gcc/testsuite/gcc.target/riscv/zbb-rol-ror-01.c b/gcc/testsuite/gcc.target/riscv/zbb-rol-ror-01.c new file mode 100644 index 0000000..9589662 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/zbb-rol-ror-01.c @@ -0,0 +1,16 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gc_zbb -mabi=lp64 -O2" } */ + +unsigned long foo1(unsigned long rs1, unsigned long rs2) +{ + long shamt = rs2 & (64 - 1); + return (rs1 << shamt) | (rs1 >> ((64 - shamt) & (64 - 1))); +} +unsigned long foo2(unsigned long rs1, unsigned long rs2) +{ + unsigned long shamt = rs2 & (64 - 1); + return (rs1 >> shamt) | (rs1 << ((64 - shamt) & (64 - 1))); +} + +/* { dg-final { scan-assembler-times "rol" 2 } } */ +/* { dg-final { scan-assembler-times "ror" 2 } } */
\ No newline at end of file diff --git a/gcc/testsuite/gcc.target/riscv/zbb-rol-ror-02.c b/gcc/testsuite/gcc.target/riscv/zbb-rol-ror-02.c new file mode 100644 index 0000000..24b482f --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/zbb-rol-ror-02.c @@ -0,0 +1,16 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv32gc_zbb -mabi=ilp32 -O2" } */ + +unsigned int foo1(unsigned int rs1, unsigned int rs2) +{ + unsigned int shamt = rs2 & (32 - 1); + return (rs1 << shamt) | (rs1 >> ((32 - shamt) & (32 - 1))); +} +unsigned int foo2(unsigned int rs1, unsigned int rs2) +{ + unsigned int shamt = rs2 & (32 - 1); + return (rs1 >> shamt) | (rs1 << ((32 - shamt) & (32 - 1))); +} + +/* { dg-final { scan-assembler-times "rol" 2 } } */ +/* { dg-final { scan-assembler-times "ror" 2 } } */
\ No newline at end of file diff --git a/gcc/testsuite/gcc.target/riscv/zbb-rol-ror-03.c b/gcc/testsuite/gcc.target/riscv/zbb-rol-ror-03.c new file mode 100644 index 0000000..ffde7c9 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/zbb-rol-ror-03.c @@ -0,0 +1,17 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gc_zbb -mabi=lp64 -O2" } */ + +/* RV64 only*/ +unsigned int rol(unsigned int rs1, unsigned int rs2) +{ + int shamt = rs2 & (32 - 1); + return (rs1 << shamt) | (rs1 >> ((64 - shamt) & (32 - 1))); +} +unsigned int ror(unsigned int rs1, unsigned int rs2) +{ + int shamt = rs2 & (64 - 1); + return (rs1 >> shamt) | (rs1 << ((32 - shamt) & (32 - 1))); +} + +/* { dg-final { scan-assembler-times "rolw" 1 } } */ +/* { dg-final { scan-assembler-times "rorw" 1 } } */
\ No newline at end of file diff --git a/gcc/testsuite/gcc.target/riscv/zbbw.c b/gcc/testsuite/gcc.target/riscv/zbbw.c new file mode 100644 index 0000000..236ddf7 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/zbbw.c @@ -0,0 +1,25 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gc_zbb -mabi=lp64 -O2" } */ + +int +clz (int i) +{ + return __builtin_clz (i); +} + +int +ctz (int i) +{ + return __builtin_ctz (i); +} + +int +popcount (int i) +{ + return __builtin_popcount (i); +} + + +/* { dg-final { scan-assembler-times "clzw" 1 } } */ +/* { dg-final { scan-assembler-times "ctzw" 1 } } */ +/* { dg-final { scan-assembler-times "cpopw" 1 } } */ diff --git a/gcc/testsuite/gcc.target/riscv/zbs-bclr.c b/gcc/testsuite/gcc.target/riscv/zbs-bclr.c new file mode 100644 index 0000000..4a3c2f1 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/zbs-bclr.c @@ -0,0 +1,20 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gc_zbs -mabi=lp64 -O2" } */ + +/* bclr */ +long +foo0 (long i, long j) +{ + return i & ~(1L << j); +} + +/* bclri */ +long +foo1 (long i) +{ + return i & ~(1L << 20); +} + +/* { dg-final { scan-assembler-times "bclr\t" 1 } } */ +/* { dg-final { scan-assembler-times "bclri\t" 1 } } */ +/* { dg-final { scan-assembler-not "andi" } } */ diff --git a/gcc/testsuite/gcc.target/riscv/zbs-bext.c b/gcc/testsuite/gcc.target/riscv/zbs-bext.c new file mode 100644 index 0000000..a093cdc --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/zbs-bext.c @@ -0,0 +1,20 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gc_zbs -mabi=lp64 -O2" } */ + +/* bext */ +long +foo0 (long i, long j) +{ + return 1L & (i >> j); +} + +/* bexti */ +long +foo1 (long i) +{ + return 1L & (i >> 20); +} + +/* { dg-final { scan-assembler-times "bexti\t" 1 } } */ +/* { dg-final { scan-assembler-times "bext\t" 1 } } */ +/* { dg-final { scan-assembler-not "andi" } } */ diff --git a/gcc/testsuite/gcc.target/riscv/zbs-binv.c b/gcc/testsuite/gcc.target/riscv/zbs-binv.c new file mode 100644 index 0000000..e4e48b9 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/zbs-binv.c @@ -0,0 +1,20 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gc_zbs -mabi=lp64 -O2" } */ + +/* binv */ +long +foo0 (long i, long j) +{ + return i ^ (1L << j); +} + +/* binvi */ +long +foo1 (long i) +{ + return i ^ (1L << 20); +} + +/* { dg-final { scan-assembler-times "binv\t" 1 } } */ +/* { dg-final { scan-assembler-times "binvi\t" 1 } } */ +/* { dg-final { scan-assembler-not "andi" } } */ diff --git a/gcc/testsuite/gcc.target/riscv/zbs-bset.c b/gcc/testsuite/gcc.target/riscv/zbs-bset.c new file mode 100644 index 0000000..733d427 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/zbs-bset.c @@ -0,0 +1,41 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gc_zbs -mabi=lp64 -O2" } */ + +/* bset */ +long +sub0 (long i, long j) +{ + return i | (1L << j); +} + +/* bset_mask */ +long +sub1 (long i, long j) +{ + return i | (1L << (j & 0x3f)); +} + +/* bset_1 */ +long +sub2 (long i) +{ + return 1L << i; +} + +/* bset_1_mask */ +long +sub3 (long i) +{ + return 1L << (i & 0x3f); +} + +/* bseti */ +long +sub4 (long i) +{ + return i | (1L << 20); +} + +/* { dg-final { scan-assembler-times "bset\t" 4 } } */ +/* { dg-final { scan-assembler-times "bseti\t" 1 } } */ +/* { dg-final { scan-assembler-not "andi" } } */ diff --git a/gcc/testsuite/gcc.target/s390/rawmemchr-1.c b/gcc/testsuite/gcc.target/s390/rawmemchr-1.c new file mode 100644 index 0000000..a512570 --- /dev/null +++ b/gcc/testsuite/gcc.target/s390/rawmemchr-1.c @@ -0,0 +1,99 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -ftree-loop-distribution -fdump-tree-ldist-details -mzarch -march=z13" } */ +/* { dg-final { scan-tree-dump-times "generated rawmemchrQI" 2 "ldist" } } */ +/* { dg-final { scan-tree-dump-times "generated rawmemchrHI" 2 "ldist" } } */ +/* { dg-final { scan-tree-dump-times "generated rawmemchrSI" 2 "ldist" } } */ + +#include <string.h> +#include <assert.h> +#include <stdint.h> +#include <stdlib.h> + +#define rawmemchrT(T, pattern) \ +__attribute__((noinline,noclone)) \ +T* rawmemchr_##T (T *s) \ +{ \ + while (*s != pattern) \ + ++s; \ + return s; \ +} + +rawmemchrT(int8_t, (int8_t)0xde) +rawmemchrT(uint8_t, 0xde) +rawmemchrT(int16_t, (int16_t)0xdead) +rawmemchrT(uint16_t, 0xdead) +rawmemchrT(int32_t, (int32_t)0xdeadbeef) +rawmemchrT(uint32_t, 0xdeadbeef) + +#define runT(T, pattern) \ +void run_##T () \ +{ \ + T *buf = malloc (4096 * 2 * sizeof(T)); \ + assert (buf != NULL); \ + memset (buf, 0xa, 4096 * 2 * sizeof(T)); \ + /* ensure q is 4096-byte aligned */ \ + T *q = (T*)((unsigned char *)buf \ + + (4096 - ((uintptr_t)buf & 4095))); \ + T *p; \ + /* unaligned + block boundary + 1st load */ \ + p = (T *) ((uintptr_t)q - 8); \ + p[2] = pattern; \ + assert ((rawmemchr_##T (&p[0]) == &p[2])); \ + p[2] = (T) 0xaaaaaaaa; \ + /* unaligned + block boundary + 2nd load */ \ + p = (T *) ((uintptr_t)q - 8); \ + p[6] = pattern; \ + assert ((rawmemchr_##T (&p[0]) == &p[6])); \ + p[6] = (T) 0xaaaaaaaa; \ + /* unaligned + 1st load */ \ + q[5] = pattern; \ + assert ((rawmemchr_##T (&q[2]) == &q[5])); \ + q[5] = (T) 0xaaaaaaaa; \ + /* unaligned + 2nd load */ \ + q[14] = pattern; \ + assert ((rawmemchr_##T (&q[2]) == &q[14])); \ + q[14] = (T) 0xaaaaaaaa; \ + /* unaligned + 3rd load */ \ + q[19] = pattern; \ + assert ((rawmemchr_##T (&q[2]) == &q[19])); \ + q[19] = (T) 0xaaaaaaaa; \ + /* unaligned + 4th load */ \ + q[25] = pattern; \ + assert ((rawmemchr_##T (&q[2]) == &q[25])); \ + q[25] = (T) 0xaaaaaaaa; \ + /* aligned + 1st load */ \ + q[5] = pattern; \ + assert ((rawmemchr_##T (&q[0]) == &q[5])); \ + q[5] = (T) 0xaaaaaaaa; \ + /* aligned + 2nd load */ \ + q[14] = pattern; \ + assert ((rawmemchr_##T (&q[0]) == &q[14])); \ + q[14] = (T) 0xaaaaaaaa; \ + /* aligned + 3rd load */ \ + q[19] = pattern; \ + assert ((rawmemchr_##T (&q[0]) == &q[19])); \ + q[19] = (T) 0xaaaaaaaa; \ + /* aligned + 4th load */ \ + q[25] = pattern; \ + assert ((rawmemchr_##T (&q[0]) == &q[25])); \ + q[25] = (T) 0xaaaaaaaa; \ + free (buf); \ +} + +runT(int8_t, (int8_t)0xde) +runT(uint8_t, 0xde) +runT(int16_t, (int16_t)0xdead) +runT(uint16_t, 0xdead) +runT(int32_t, (int32_t)0xdeadbeef) +runT(uint32_t, 0xdeadbeef) + +int main (void) +{ + run_uint8_t (); + run_int8_t (); + run_uint16_t (); + run_int16_t (); + run_uint32_t (); + run_int32_t (); + return 0; +} diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_19.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_19.f90 new file mode 100644 index 0000000..8cc1601 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_19.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! This testcase failed before with optimization as +! allocatef's CFI descriptor argument 'x' failed with -fstrict-alias due to +! internally alising with the GFC descriptor +! + +program testit + use iso_c_binding + implicit none (external, type) + type, bind (c) :: m + integer(C_INT) :: i, j + end type + type(m), allocatable :: a(:) + + call testf (a) + +contains + subroutine allocatef (x) bind (c) + type(m), allocatable :: x(:) + allocate (x(5:15)) + end subroutine + + subroutine testf (y) + type(m), allocatable, target :: y(:) + call allocatef (y) + if (.not. allocated (y)) stop 1 + end subroutine +end program diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90 index 7731d1a..c596e47 100644 --- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90 +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90 @@ -19,23 +19,37 @@ contains subroutine substr(str) BIND(C) character(*) :: str(:) - if (str(2) .ne. "ghi") stop 2 + if (str(1) .ne. "bcd") stop 2 + if (str(2) .ne. "ghi") stop 3 str = ['uvw','xyz'] end subroutine + subroutine substr4(str4) BIND(C) + character(*, kind=4) :: str4(:) + print *, str4(1) + print *, str4(2) + if (str4(1) .ne. 4_"bcd") stop 4 + if (str4(2) .ne. 4_"ghi") stop 5 + str4 = [4_'uvw', 4_'xyz'] + end subroutine + end module program p use mod_ctg implicit none real :: x(6) - character(5) :: str(2) = ['abcde','fghij'] + character(5) :: str(2) = ['abcde', 'fghij'] + character(5, kind=4) :: str4(2) = [4_'abcde', 4_'fghij'] integer :: i x = [ (real(i), i=1, size(x)) ] call ctg(x(2::2)) if (any (abs (x - [1.,20.,3.,40.,5.,60.]) > 1.e-6)) stop 3 - call substr(str(:)(2:4)) - if (any (str .ne. ['auvwe','fxyzj'])) stop 4 + !call substr(str(:)(2:4)) + !if (any (str .ne. ['auvwe','fxyzj'])) stop 4 + + call substr4(str4(:)(2:4)) + if (any (str4 .ne. [4_'auvwe', 4_'fxyzj'])) stop 4 end program diff --git a/gcc/testsuite/gfortran.dg/PR100906.c b/gcc/testsuite/gfortran.dg/PR100906.c new file mode 100644 index 0000000..f71d5677 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR100906.c @@ -0,0 +1,169 @@ +/* Test the fix for PR100906 */ + +#include <assert.h> +#include <stdbool.h> +#include <stdint.h> +#include <stdio.h> +/* #include <uchar.h> */ + +#include <ISO_Fortran_binding.h> + +#define _CFI_type_mask 0xFF +#define _CFI_type_kind_shift 8 + +#define _CFI_decode_type(NAME) (signed char)((NAME) & CFI_type_mask) +#define _CFI_decode_kind(NAME) (signed char)(((NAME) >> CFI_type_kind_shift) & CFI_type_mask) + +#define _CFI_encode_type(TYPE, KIND) (int16_t)\ +((((KIND) & CFI_type_mask) << CFI_type_kind_shift)\ + | ((TYPE) & CFI_type_mask)) + +#define N 11 +#define M 7 + +typedef char c_char; +/* typedef char32_t c_ucs4_char; */ +typedef uint32_t char32_t; +typedef uint32_t c_ucs4_char; + +bool charcmp (char *, char, size_t); + +bool ucharcmp (char32_t *, char32_t, size_t); + +bool c_vrfy_c_char (const CFI_cdesc_t *restrict, const size_t); + +bool c_vrfy_c_ucs4_char (const CFI_cdesc_t *restrict, const size_t); + +bool c_vrfy_character (const CFI_cdesc_t *restrict, const size_t); + +void check_tk (const CFI_cdesc_t*restrict, const CFI_type_t, const signed char, const size_t, const size_t); + +bool +charcmp (char *c, char v, size_t n) +{ + bool res = true; + char b = (char)'A'; + size_t i; + + for (i=0; ((i<n)&&(res)); i++, c++) + res = (*c == (v+b)); + return res; +} + +bool +ucharcmp (char32_t *c, char32_t v, size_t n) +{ + bool res = true; + char32_t b = (char32_t)0xFF01; + size_t i; + + for (i=0; ((i<n)&&(res)); i++, c++) + res = (*c == (v+b)); + return res; +} + +bool +c_vrfy_c_char (const CFI_cdesc_t *restrict auxp, const size_t len) +{ + CFI_index_t i, lb, ub, ex; + size_t sz; + c_char *ip = NULL; + + assert (auxp); + assert (auxp->base_addr); + assert (auxp->elem_len>0); + lb = auxp->dim[0].lower_bound; + ex = auxp->dim[0].extent; + assert (ex==N); + sz = (size_t)auxp->elem_len / sizeof (c_char); + assert (sz==len); + ub = ex + lb - 1; + ip = (c_char*)auxp->base_addr; + for (i=0; i<ex; i++, ip+=sz) + if (!charcmp (ip, (c_char)(i), sz)) + return false; + for (i=lb; i<ub+1; i++) + { + ip = (c_char*)CFI_address(auxp, &i); + if (!charcmp (ip, (c_char)(i-lb), sz)) + return false; + } + return true; +} + +bool +c_vrfy_c_ucs4_char (const CFI_cdesc_t *restrict auxp, const size_t len) +{ + CFI_index_t i, lb, ub, ex; + size_t sz; + c_ucs4_char *ip = NULL; + + assert (auxp); + assert (auxp->base_addr); + assert (auxp->elem_len>0); + lb = auxp->dim[0].lower_bound; + ex = auxp->dim[0].extent; + assert (ex==N); + sz = (size_t)auxp->elem_len / sizeof (c_ucs4_char); + assert (sz==len); + ub = ex + lb - 1; + ip = (c_ucs4_char*)auxp->base_addr; + for (i=0; i<ex; i++, ip+=sz) + if (!ucharcmp (ip, (c_ucs4_char)(i), sz)) + return false; + for (i=lb; i<ub+1; i++) + { + ip = (c_ucs4_char*)CFI_address(auxp, &i); + if (!ucharcmp (ip, (c_ucs4_char)(i-lb), sz)) + return false; + } + return true; +} + +bool +c_vrfy_character (const CFI_cdesc_t *restrict auxp, const size_t len) +{ + signed char type, kind; + + assert (auxp); + type = _CFI_decode_type(auxp->type); + kind = _CFI_decode_kind(auxp->type); + assert (type == CFI_type_Character); + switch (kind) + { + case 1: + return c_vrfy_c_char (auxp, len); + break; + case 4: + return c_vrfy_c_ucs4_char (auxp, len); + break; + default: + assert (false); + } + return true; +} + +void +check_tk (const CFI_cdesc_t *restrict auxp, const CFI_type_t type, const signed char kind, const size_t elem_len, const size_t nelem) +{ + signed char ityp, iknd; + + assert (auxp); + assert (auxp->elem_len==elem_len*nelem); + assert (auxp->rank==1); + assert (auxp->dim[0].sm>0); + assert ((size_t)auxp->dim[0].sm==elem_len*nelem); + /* */ + assert (auxp->type==type); + ityp = _CFI_decode_type(auxp->type); + assert (ityp == CFI_type_Character); + iknd = _CFI_decode_kind(auxp->type); + assert (_CFI_decode_type(type)==ityp); + assert (kind==iknd); + assert (c_vrfy_character (auxp, nelem)); + return; +} + +// Local Variables: +// mode: C +// End: diff --git a/gcc/testsuite/gfortran.dg/PR100906.f90 b/gcc/testsuite/gfortran.dg/PR100906.f90 new file mode 100644 index 0000000..f6cb3af --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR100906.f90 @@ -0,0 +1,1699 @@ +! { dg-do run } +! { dg-additional-sources PR100906.c } +! +! Test the fix for PR100906 +! + +module isof_m + + use, intrinsic :: iso_c_binding, only: & + c_signed_char, c_int16_t + + implicit none + + private + + public :: & + CFI_type_character + + public :: & + CFI_type_char, & + CFI_type_ucs4_char + + public :: & + check_tk_as, & + check_tk_ar + + + public :: & + cfi_encode_type + + integer, parameter :: CFI_type_t = c_int16_t + + integer(kind=c_int16_t), parameter :: CFI_type_mask = int(z"FF", kind=c_int16_t) + integer(kind=c_int16_t), parameter :: CFI_type_kind_shift = 8_c_int16_t + + ! Intrinsic types. Their kind number defines their storage size. */ + integer(kind=c_signed_char), parameter :: CFI_type_Character = 5 + + ! C-Fortran Interoperability types. + integer(kind=cfi_type_t), parameter :: CFI_type_char = & + ior(int(CFI_type_Character, kind=c_int16_t), shiftl(1_c_int16_t, CFI_type_kind_shift)) + integer(kind=cfi_type_t), parameter :: CFI_type_ucs4_char = & + ior(int(CFI_type_Character, kind=c_int16_t), shiftl(4_c_int16_t, CFI_type_kind_shift)) + + interface + subroutine check_tk_as(a, t, k, e, n) & + bind(c, name="check_tk") + use, intrinsic :: iso_c_binding, only: & + c_int16_t, c_signed_char, c_size_t + implicit none + type(*), intent(in) :: a(:) + integer(c_int16_t), value, intent(in) :: t + integer(c_signed_char), value, intent(in) :: k + integer(c_size_t), value, intent(in) :: e + integer(c_size_t), value, intent(in) :: n + end subroutine check_tk_as + subroutine check_tk_ar(a, t, k, e, n) & + bind(c, name="check_tk") + use, intrinsic :: iso_c_binding, only: & + c_int16_t, c_signed_char, c_size_t + implicit none + type(*), intent(in) :: a(..) + integer(c_int16_t), value, intent(in) :: t + integer(c_signed_char), value, intent(in) :: k + integer(c_size_t), value, intent(in) :: e + integer(c_size_t), value, intent(in) :: n + end subroutine check_tk_ar + end interface + +contains + + elemental function cfi_encode_type(type, kind) result(itype) + integer(kind=c_signed_char), intent(in) :: type + integer(kind=c_signed_char), intent(in) :: kind + + integer(kind=c_int16_t) :: itype, ikind + + itype = int(type, kind=c_int16_t) + itype = iand(itype, CFI_type_mask) + ikind = int(kind, kind=c_int16_t) + ikind = iand(ikind, CFI_type_mask) + ikind = shiftl(ikind, CFI_type_kind_shift) + itype = ior(ikind, itype) + return + end function cfi_encode_type + +end module isof_m + +module iso_check_m + + use, intrinsic :: iso_c_binding, only: & + c_signed_char, c_int16_t, c_size_t + + use, intrinsic :: iso_c_binding, only: & + c_char + + use :: isof_m, only: & + CFI_type_character + + use :: isof_m, only: & + CFI_type_char, & + CFI_type_ucs4_char + + use :: isof_m, only: & + check_tk_as, & + check_tk_ar + + use :: isof_m, only: & + cfi_encode_type + + implicit none + + private + + public :: & + check_c_char_l1, & + check_c_char_lm, & + check_c_ucs4_char_l1, & + check_c_ucs4_char_lm + + integer :: i + integer(kind=c_size_t), parameter :: b = 8 + integer, parameter :: n = 11 + integer, parameter :: m = 7 + + integer, parameter :: c_ucs4_char = 4 + + character(kind=c_char, len=1), parameter :: ref_c_char_l1(*) = & + [(achar(i+iachar("A")-1, kind=c_char), i=1,n)] + character(kind=c_char, len=m), parameter :: ref_c_char_lm(*) = & + [(repeat(achar(i+iachar("A")-1, kind=c_char), m), i=1,n)] + character(kind=c_ucs4_char, len=1), parameter :: ref_c_ucs4_char_l1(*) = & + [(achar(i+iachar("A")-1, kind=c_ucs4_char), i=1,n)] + character(kind=c_ucs4_char, len=m), parameter :: ref_c_ucs4_char_lm(*) = & + [(repeat(achar(i+iachar("A")-1, kind=c_ucs4_char), m), i=1,n)] + +contains + + subroutine check_c_char_l1() + character(kind=c_char, len=1), target :: a(n) + ! + character(kind=c_char, len=:), pointer :: p(:) + ! + a = ref_c_char_l1 + call f_check_c_char_c1_as(a) + if(any(a/=ref_c_char_l1)) stop 1 + a = ref_c_char_l1 + call c_check_c_char_c1_as(a) + if(any(a/=ref_c_char_l1)) stop 2 + a = ref_c_char_l1 + call f_check_c_char_c1_ar(a) + if(any(a/=ref_c_char_l1)) stop 3 + a = ref_c_char_l1 + call c_check_c_char_c1_ar(a) + if(any(a/=ref_c_char_l1)) stop 4 + a = ref_c_char_l1 + call f_check_c_char_a1_as(a) + if(any(a/=ref_c_char_l1)) stop 5 + a = ref_c_char_l1 + call c_check_c_char_a1_as(a) + if(any(a/=ref_c_char_l1)) stop 6 + a = ref_c_char_l1 + call f_check_c_char_a1_ar(a) + if(any(a/=ref_c_char_l1)) stop 7 + a = ref_c_char_l1 + call c_check_c_char_a1_ar(a) + if(any(a/=ref_c_char_l1)) stop 8 + a = ref_c_char_l1 + p => a + call f_check_c_char_d1_as(p) + if(.not.associated(p)) stop 9 + if(.not.associated(p, a)) stop 10 + if(any(p/=ref_c_char_l1)) stop 11 + if(any(a/=ref_c_char_l1)) stop 12 + a = ref_c_char_l1 + p => a + call c_check_c_char_d1_as(p) + if(.not.associated(p)) stop 13 + if(.not.associated(p, a)) stop 14 + if(any(p/=ref_c_char_l1)) stop 15 + if(any(a/=ref_c_char_l1)) stop 16 + a = ref_c_char_l1 + p => a + call f_check_c_char_d1_ar(p) + if(.not.associated(p)) stop 17 + if(.not.associated(p, a)) stop 18 + if(any(p/=ref_c_char_l1)) stop 19 + if(any(a/=ref_c_char_l1)) stop 20 + a = ref_c_char_l1 + p => a + call c_check_c_char_d1_ar(p) + if(.not.associated(p)) stop 21 + if(.not.associated(p, a)) stop 22 + if(any(p/=ref_c_char_l1)) stop 23 + if(any(a/=ref_c_char_l1)) stop 24 + return + end subroutine check_c_char_l1 + + subroutine f_check_c_char_c1_as(a) + character(kind=c_char, len=1), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 25 + if(k/=1_c_signed_char) stop 26 + if(n/=1) stop 27 + if(int(k, kind=c_size_t)/=e) stop 28 + if(t/=CFI_type_char) stop 29 + if(any(a/=ref_c_char_l1)) stop 30 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_char_l1)) stop 31 + return + end subroutine f_check_c_char_c1_as + + subroutine c_check_c_char_c1_as(a) bind(c) + character(kind=c_char, len=1), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 32 + if(k/=1_c_signed_char) stop 33 + if(n/=1) stop 34 + if(int(k, kind=c_size_t)/=e) stop 35 + if(t/=CFI_type_char) stop 36 + if(any(a/=ref_c_char_l1)) stop 37 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_char_l1)) stop 38 + return + end subroutine c_check_c_char_c1_as + + subroutine f_check_c_char_c1_ar(a) + character(kind=c_char, len=1), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 39 + if(k/=1_c_signed_char) stop 40 + if(n/=1) stop 41 + if(int(k, kind=c_size_t)/=e) stop 42 + if(t/=CFI_type_char) stop 43 + select rank(a) + rank(1) + if(any(a/=ref_c_char_l1)) stop 44 + rank default + stop 45 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_char_l1)) stop 46 + rank default + stop 47 + end select + return + end subroutine f_check_c_char_c1_ar + + subroutine c_check_c_char_c1_ar(a) bind(c) + character(kind=c_char, len=1), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 48 + if(k/=1_c_signed_char) stop 49 + if(n/=1) stop 50 + if(int(k, kind=c_size_t)/=e) stop 51 + if(t/=CFI_type_char) stop 52 + select rank(a) + rank(1) + if(any(a/=ref_c_char_l1)) stop 53 + rank default + stop 54 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_char_l1)) stop 55 + rank default + stop 56 + end select + return + end subroutine c_check_c_char_c1_ar + + subroutine f_check_c_char_a1_as(a) + character(kind=c_char, len=*), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 57 + if(k/=1_c_signed_char) stop 58 + if(n/=1) stop 59 + if(int(k, kind=c_size_t)/=e) stop 60 + if(t/=CFI_type_char) stop 61 + if(any(a/=ref_c_char_l1)) stop 62 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_char_l1)) stop 63 + return + end subroutine f_check_c_char_a1_as + + subroutine c_check_c_char_a1_as(a) bind(c) + character(kind=c_char, len=*), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 64 + if(k/=1_c_signed_char) stop 65 + if(n/=1) stop 66 + if(int(k, kind=c_size_t)/=e) stop 67 + if(t/=CFI_type_char) stop 68 + if(any(a/=ref_c_char_l1)) stop 69 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_char_l1)) stop 70 + return + end subroutine c_check_c_char_a1_as + + subroutine f_check_c_char_a1_ar(a) + character(kind=c_char, len=*), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 71 + if(k/=1_c_signed_char) stop 72 + if(n/=1) stop 73 + if(int(k, kind=c_size_t)/=e) stop 74 + if(t/=CFI_type_char) stop 75 + select rank(a) + rank(1) + if(any(a/=ref_c_char_l1)) stop 76 + rank default + stop 77 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_char_l1)) stop 78 + rank default + stop 79 + end select + return + end subroutine f_check_c_char_a1_ar + + subroutine c_check_c_char_a1_ar(a) bind(c) + character(kind=c_char, len=*), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 80 + if(k/=1_c_signed_char) stop 81 + if(n/=1) stop 82 + if(int(k, kind=c_size_t)/=e) stop 83 + if(t/=CFI_type_char) stop 84 + select rank(a) + rank(1) + if(any(a/=ref_c_char_l1)) stop 85 + rank default + stop 86 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_char_l1)) stop 87 + rank default + stop 88 + end select + return + end subroutine c_check_c_char_a1_ar + + subroutine f_check_c_char_d1_as(a) + character(kind=c_char, len=:), pointer, intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 89 + if(k/=1_c_signed_char) stop 90 + if(n/=1) stop 91 + if(int(k, kind=c_size_t)/=e) stop 92 + if(t/=CFI_type_char) stop 93 + if(any(a/=ref_c_char_l1)) stop 94 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_char_l1)) stop 95 + return + end subroutine f_check_c_char_d1_as + + subroutine c_check_c_char_d1_as(a) bind(c) + character(kind=c_char, len=:), pointer, intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 96 + if(k/=1_c_signed_char) stop 97 + if(n/=1) stop 98 + if(int(k, kind=c_size_t)/=e) stop 99 + if(t/=CFI_type_char) stop 100 + if(any(a/=ref_c_char_l1)) stop 101 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_char_l1)) stop 102 + return + end subroutine c_check_c_char_d1_as + + subroutine f_check_c_char_d1_ar(a) + character(kind=c_char, len=:), pointer, intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 103 + if(k/=1_c_signed_char) stop 104 + if(n/=1) stop 105 + if(int(k, kind=c_size_t)/=e) stop 106 + if(t/=CFI_type_char) stop 107 + select rank(a) + rank(1) + if(any(a/=ref_c_char_l1)) stop 108 + rank default + stop 109 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_char_l1)) stop 110 + rank default + stop 111 + end select + return + end subroutine f_check_c_char_d1_ar + + subroutine c_check_c_char_d1_ar(a) bind(c) + character(kind=c_char, len=:), pointer, intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 112 + if(k/=1_c_signed_char) stop 113 + if(n/=1) stop 114 + if(int(k, kind=c_size_t)/=e) stop 115 + if(t/=CFI_type_char) stop 116 + select rank(a) + rank(1) + if(any(a/=ref_c_char_l1)) stop 117 + rank default + stop 118 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_char_l1)) stop 119 + rank default + stop 120 + end select + return + end subroutine c_check_c_char_d1_ar + + subroutine check_c_char_lm() + character(kind=c_char, len=m), target :: a(n) + ! + character(kind=c_char, len=:), pointer :: p(:) + ! + a = ref_c_char_lm + call f_check_c_char_cm_as(a) + if(any(a/=ref_c_char_lm)) stop 121 + a = ref_c_char_lm + call c_check_c_char_cm_as(a) + if(any(a/=ref_c_char_lm)) stop 122 + a = ref_c_char_lm + call f_check_c_char_cm_ar(a) + if(any(a/=ref_c_char_lm)) stop 123 + a = ref_c_char_lm + call c_check_c_char_cm_ar(a) + if(any(a/=ref_c_char_lm)) stop 124 + a = ref_c_char_lm + call f_check_c_char_am_as(a) + if(any(a/=ref_c_char_lm)) stop 125 + a = ref_c_char_lm + call c_check_c_char_am_as(a) + if(any(a/=ref_c_char_lm)) stop 126 + a = ref_c_char_lm + call f_check_c_char_am_ar(a) + if(any(a/=ref_c_char_lm)) stop 127 + a = ref_c_char_lm + call c_check_c_char_am_ar(a) + if(any(a/=ref_c_char_lm)) stop 128 + a = ref_c_char_lm + p => a + call f_check_c_char_dm_as(p) + if(.not.associated(p)) stop 129 + if(.not.associated(p, a)) stop 130 + if(any(p/=ref_c_char_lm)) stop 131 + if(any(a/=ref_c_char_lm)) stop 132 + a = ref_c_char_lm + p => a + call c_check_c_char_dm_as(p) + if(.not.associated(p)) stop 133 + if(.not.associated(p, a)) stop 134 + if(any(p/=ref_c_char_lm)) stop 135 + if(any(a/=ref_c_char_lm)) stop 136 + a = ref_c_char_lm + p => a + call f_check_c_char_dm_ar(p) + if(.not.associated(p)) stop 137 + if(.not.associated(p, a)) stop 138 + if(any(p/=ref_c_char_lm)) stop 139 + if(any(a/=ref_c_char_lm)) stop 140 + a = ref_c_char_lm + p => a + call c_check_c_char_dm_ar(p) + if(.not.associated(p)) stop 141 + if(.not.associated(p, a)) stop 142 + if(any(p/=ref_c_char_lm)) stop 143 + if(any(a/=ref_c_char_lm)) stop 144 + return + end subroutine check_c_char_lm + + subroutine f_check_c_char_cm_as(a) + character(kind=c_char, len=m), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 145 + if(k/=1_c_signed_char) stop 146 + if(n/=m) stop 147 + if(int(k, kind=c_size_t)/=e) stop 148 + if(t/=CFI_type_char) stop 149 + if(any(a/=ref_c_char_lm)) stop 150 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_char_lm)) stop 151 + return + end subroutine f_check_c_char_cm_as + + subroutine c_check_c_char_cm_as(a) bind(c) + character(kind=c_char, len=m), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 152 + if(k/=1_c_signed_char) stop 153 + if(n/=m) stop 154 + if(int(k, kind=c_size_t)/=e) stop 155 + if(t/=CFI_type_char) stop 156 + if(any(a/=ref_c_char_lm)) stop 157 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_char_lm)) stop 158 + return + end subroutine c_check_c_char_cm_as + + subroutine f_check_c_char_cm_ar(a) + character(kind=c_char, len=m), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 159 + if(k/=1_c_signed_char) stop 160 + if(n/=m) stop 161 + if(int(k, kind=c_size_t)/=e) stop 162 + if(t/=CFI_type_char) stop 163 + select rank(a) + rank(1) + if(any(a/=ref_c_char_lm)) stop 164 + rank default + stop 165 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_char_lm)) stop 166 + rank default + stop 167 + end select + return + end subroutine f_check_c_char_cm_ar + + subroutine c_check_c_char_cm_ar(a) bind(c) + character(kind=c_char, len=m), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 168 + if(k/=1_c_signed_char) stop 169 + if(n/=m) stop 170 + if(int(k, kind=c_size_t)/=e) stop 171 + if(t/=CFI_type_char) stop 172 + select rank(a) + rank(1) + if(any(a/=ref_c_char_lm)) stop 173 + rank default + stop 174 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_char_lm)) stop 175 + rank default + stop 176 + end select + return + end subroutine c_check_c_char_cm_ar + + subroutine f_check_c_char_am_as(a) + character(kind=c_char, len=*), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 177 + if(k/=1_c_signed_char) stop 178 + if(n/=m) stop 179 + if(int(k, kind=c_size_t)/=e) stop 180 + if(t/=CFI_type_char) stop 181 + if(any(a/=ref_c_char_lm)) stop 182 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_char_lm)) stop 183 + return + end subroutine f_check_c_char_am_as + + subroutine c_check_c_char_am_as(a) bind(c) + character(kind=c_char, len=*), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 184 + if(k/=1_c_signed_char) stop 185 + if(n/=m) stop 186 + if(int(k, kind=c_size_t)/=e) stop 187 + if(t/=CFI_type_char) stop 188 + if(any(a/=ref_c_char_lm)) stop 189 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_char_lm)) stop 190 + return + end subroutine c_check_c_char_am_as + + subroutine f_check_c_char_am_ar(a) + character(kind=c_char, len=*), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 191 + if(k/=1_c_signed_char) stop 192 + if(n/=m) stop 193 + if(int(k, kind=c_size_t)/=e) stop 194 + if(t/=CFI_type_char) stop 195 + select rank(a) + rank(1) + if(any(a/=ref_c_char_lm)) stop 196 + rank default + stop 197 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_char_lm)) stop 198 + rank default + stop 199 + end select + return + end subroutine f_check_c_char_am_ar + + subroutine c_check_c_char_am_ar(a) bind(c) + character(kind=c_char, len=*), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 200 + if(k/=1_c_signed_char) stop 201 + if(n/=m) stop 202 + if(int(k, kind=c_size_t)/=e) stop 203 + if(t/=CFI_type_char) stop 204 + select rank(a) + rank(1) + if(any(a/=ref_c_char_lm)) stop 205 + rank default + stop 206 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_char_lm)) stop 207 + rank default + stop 208 + end select + return + end subroutine c_check_c_char_am_ar + + subroutine f_check_c_char_dm_as(a) + character(kind=c_char, len=:), pointer, intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 209 + if(k/=1_c_signed_char) stop 210 + if(n/=m) stop 211 + if(int(k, kind=c_size_t)/=e) stop 212 + if(t/=CFI_type_char) stop 213 + if(any(a/=ref_c_char_lm)) stop 214 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_char_lm)) stop 215 + return + end subroutine f_check_c_char_dm_as + + subroutine c_check_c_char_dm_as(a) bind(c) + character(kind=c_char, len=:), pointer, intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 216 + if(k/=1_c_signed_char) stop 217 + if(n/=m) stop 218 + if(int(k, kind=c_size_t)/=e) stop 219 + if(t/=CFI_type_char) stop 220 + if(any(a/=ref_c_char_lm)) stop 221 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_char_lm)) stop 222 + return + end subroutine c_check_c_char_dm_as + + subroutine f_check_c_char_dm_ar(a) + character(kind=c_char, len=:), pointer, intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 223 + if(k/=1_c_signed_char) stop 224 + if(n/=m) stop 225 + if(int(k, kind=c_size_t)/=e) stop 226 + if(t/=CFI_type_char) stop 227 + select rank(a) + rank(1) + if(any(a/=ref_c_char_lm)) stop 228 + rank default + stop 229 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_char_lm)) stop 230 + rank default + stop 231 + end select + return + end subroutine f_check_c_char_dm_ar + + subroutine c_check_c_char_dm_ar(a) bind(c) + character(kind=c_char, len=:), pointer, intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 232 + if(k/=1_c_signed_char) stop 233 + if(n/=m) stop 234 + if(int(k, kind=c_size_t)/=e) stop 235 + if(t/=CFI_type_char) stop 236 + select rank(a) + rank(1) + if(any(a/=ref_c_char_lm)) stop 237 + rank default + stop 238 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_char_lm)) stop 239 + rank default + stop 240 + end select + return + end subroutine c_check_c_char_dm_ar + + subroutine check_c_ucs4_char_l1() + character(kind=c_ucs4_char, len=1), target :: a(n) + ! + character(kind=c_ucs4_char, len=:), pointer :: p(:) + ! + a = ref_c_ucs4_char_l1 + call f_check_c_ucs4_char_c1_as(a) + if(any(a/=ref_c_ucs4_char_l1)) stop 241 + a = ref_c_ucs4_char_l1 + call c_check_c_ucs4_char_c1_as(a) + if(any(a/=ref_c_ucs4_char_l1)) stop 242 + a = ref_c_ucs4_char_l1 + call f_check_c_ucs4_char_c1_ar(a) + if(any(a/=ref_c_ucs4_char_l1)) stop 243 + a = ref_c_ucs4_char_l1 + call c_check_c_ucs4_char_c1_ar(a) + if(any(a/=ref_c_ucs4_char_l1)) stop 244 + a = ref_c_ucs4_char_l1 + call f_check_c_ucs4_char_a1_as(a) + if(any(a/=ref_c_ucs4_char_l1)) stop 245 + a = ref_c_ucs4_char_l1 + call c_check_c_ucs4_char_a1_as(a) + if(any(a/=ref_c_ucs4_char_l1)) stop 246 + a = ref_c_ucs4_char_l1 + call f_check_c_ucs4_char_a1_ar(a) + if(any(a/=ref_c_ucs4_char_l1)) stop 247 + a = ref_c_ucs4_char_l1 + call c_check_c_ucs4_char_a1_ar(a) + if(any(a/=ref_c_ucs4_char_l1)) stop 248 + a = ref_c_ucs4_char_l1 + p => a + call f_check_c_ucs4_char_d1_as(p) + if(.not.associated(p)) stop 249 + if(.not.associated(p, a)) stop 250 + if(any(p/=ref_c_ucs4_char_l1)) stop 251 + if(any(a/=ref_c_ucs4_char_l1)) stop 252 + a = ref_c_ucs4_char_l1 + p => a + call c_check_c_ucs4_char_d1_as(p) + if(.not.associated(p)) stop 253 + if(.not.associated(p, a)) stop 254 + if(any(p/=ref_c_ucs4_char_l1)) stop 255 + if(any(a/=ref_c_ucs4_char_l1)) stop 256 + a = ref_c_ucs4_char_l1 + p => a + call f_check_c_ucs4_char_d1_ar(p) + if(.not.associated(p)) stop 257 + if(.not.associated(p, a)) stop 258 + if(any(p/=ref_c_ucs4_char_l1)) stop 259 + if(any(a/=ref_c_ucs4_char_l1)) stop 260 + a = ref_c_ucs4_char_l1 + p => a + call c_check_c_ucs4_char_d1_ar(p) + if(.not.associated(p)) stop 261 + if(.not.associated(p, a)) stop 262 + if(any(p/=ref_c_ucs4_char_l1)) stop 263 + if(any(a/=ref_c_ucs4_char_l1)) stop 264 + return + end subroutine check_c_ucs4_char_l1 + + subroutine f_check_c_ucs4_char_c1_as(a) + character(kind=c_ucs4_char, len=1), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 265 + if(k/=4_c_signed_char) stop 266 + if(n/=1) stop 267 + if(int(k, kind=c_size_t)/=e) stop 268 + if(t/=CFI_type_ucs4_char) stop 269 + if(any(a/=ref_c_ucs4_char_l1)) stop 270 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_ucs4_char_l1)) stop 271 + return + end subroutine f_check_c_ucs4_char_c1_as + + subroutine c_check_c_ucs4_char_c1_as(a) bind(c) + character(kind=c_ucs4_char, len=1), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 272 + if(k/=4_c_signed_char) stop 273 + if(n/=1) stop 274 + if(int(k, kind=c_size_t)/=e) stop 275 + if(t/=CFI_type_ucs4_char) stop 276 + if(any(a/=ref_c_ucs4_char_l1)) stop 277 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_ucs4_char_l1)) stop 278 + return + end subroutine c_check_c_ucs4_char_c1_as + + subroutine f_check_c_ucs4_char_c1_ar(a) + character(kind=c_ucs4_char, len=1), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 279 + if(k/=4_c_signed_char) stop 280 + if(n/=1) stop 281 + if(int(k, kind=c_size_t)/=e) stop 282 + if(t/=CFI_type_ucs4_char) stop 283 + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_l1)) stop 284 + rank default + stop 285 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_l1)) stop 286 + rank default + stop 287 + end select + return + end subroutine f_check_c_ucs4_char_c1_ar + + subroutine c_check_c_ucs4_char_c1_ar(a) bind(c) + character(kind=c_ucs4_char, len=1), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 288 + if(k/=4_c_signed_char) stop 289 + if(n/=1) stop 290 + if(int(k, kind=c_size_t)/=e) stop 291 + if(t/=CFI_type_ucs4_char) stop 292 + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_l1)) stop 293 + rank default + stop 294 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_l1)) stop 295 + rank default + stop 296 + end select + return + end subroutine c_check_c_ucs4_char_c1_ar + + subroutine f_check_c_ucs4_char_a1_as(a) + character(kind=c_ucs4_char, len=*), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 297 + if(k/=4_c_signed_char) stop 298 + if(n/=1) stop 299 + if(int(k, kind=c_size_t)/=e) stop 300 + if(t/=CFI_type_ucs4_char) stop 301 + if(any(a/=ref_c_ucs4_char_l1)) stop 302 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_ucs4_char_l1)) stop 303 + return + end subroutine f_check_c_ucs4_char_a1_as + + subroutine c_check_c_ucs4_char_a1_as(a) bind(c) + character(kind=c_ucs4_char, len=*), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 304 + if(k/=4_c_signed_char) stop 305 + if(n/=1) stop 306 + if(int(k, kind=c_size_t)/=e) stop 307 + if(t/=CFI_type_ucs4_char) stop 308 + if(any(a/=ref_c_ucs4_char_l1)) stop 309 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_ucs4_char_l1)) stop 310 + return + end subroutine c_check_c_ucs4_char_a1_as + + subroutine f_check_c_ucs4_char_a1_ar(a) + character(kind=c_ucs4_char, len=*), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 311 + if(k/=4_c_signed_char) stop 312 + if(n/=1) stop 313 + if(int(k, kind=c_size_t)/=e) stop 314 + if(t/=CFI_type_ucs4_char) stop 315 + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_l1)) stop 316 + rank default + stop 317 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_l1)) stop 318 + rank default + stop 319 + end select + return + end subroutine f_check_c_ucs4_char_a1_ar + + subroutine c_check_c_ucs4_char_a1_ar(a) bind(c) + character(kind=c_ucs4_char, len=*), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 320 + if(k/=4_c_signed_char) stop 321 + if(n/=1) stop 322 + if(int(k, kind=c_size_t)/=e) stop 323 + if(t/=CFI_type_ucs4_char) stop 324 + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_l1)) stop 325 + rank default + stop 326 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_l1)) stop 327 + rank default + stop 328 + end select + return + end subroutine c_check_c_ucs4_char_a1_ar + + subroutine f_check_c_ucs4_char_d1_as(a) + character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 329 + if(k/=4_c_signed_char) stop 330 + if(n/=1) stop 331 + if(int(k, kind=c_size_t)/=e) stop 332 + if(t/=CFI_type_ucs4_char) stop 333 + if(any(a/=ref_c_ucs4_char_l1)) stop 334 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_ucs4_char_l1)) stop 335 + return + end subroutine f_check_c_ucs4_char_d1_as + + subroutine c_check_c_ucs4_char_d1_as(a) bind(c) + character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 336 + if(k/=4_c_signed_char) stop 337 + if(n/=1) stop 338 + if(int(k, kind=c_size_t)/=e) stop 339 + if(t/=CFI_type_ucs4_char) stop 340 + if(any(a/=ref_c_ucs4_char_l1)) stop 341 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_ucs4_char_l1)) stop 342 + return + end subroutine c_check_c_ucs4_char_d1_as + + subroutine f_check_c_ucs4_char_d1_ar(a) + character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 343 + if(k/=4_c_signed_char) stop 344 + if(n/=1) stop 345 + if(int(k, kind=c_size_t)/=e) stop 346 + if(t/=CFI_type_ucs4_char) stop 347 + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_l1)) stop 348 + rank default + stop 349 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_l1)) stop 350 + rank default + stop 351 + end select + return + end subroutine f_check_c_ucs4_char_d1_ar + + subroutine c_check_c_ucs4_char_d1_ar(a) bind(c) + character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*1) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 352 + if(k/=4_c_signed_char) stop 353 + if(n/=1) stop 354 + if(int(k, kind=c_size_t)/=e) stop 355 + if(t/=CFI_type_ucs4_char) stop 356 + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_l1)) stop 357 + rank default + stop 358 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_l1)) stop 359 + rank default + stop 360 + end select + return + end subroutine c_check_c_ucs4_char_d1_ar + + subroutine check_c_ucs4_char_lm() + character(kind=c_ucs4_char, len=m), target :: a(n) + ! + character(kind=c_ucs4_char, len=:), pointer :: p(:) + ! + a = ref_c_ucs4_char_lm + call f_check_c_ucs4_char_cm_as(a) + if(any(a/=ref_c_ucs4_char_lm)) stop 361 + a = ref_c_ucs4_char_lm + call c_check_c_ucs4_char_cm_as(a) + if(any(a/=ref_c_ucs4_char_lm)) stop 362 + a = ref_c_ucs4_char_lm + call f_check_c_ucs4_char_cm_ar(a) + if(any(a/=ref_c_ucs4_char_lm)) stop 363 + a = ref_c_ucs4_char_lm + call c_check_c_ucs4_char_cm_ar(a) + if(any(a/=ref_c_ucs4_char_lm)) stop 364 + a = ref_c_ucs4_char_lm + call f_check_c_ucs4_char_am_as(a) + if(any(a/=ref_c_ucs4_char_lm)) stop 365 + a = ref_c_ucs4_char_lm + call c_check_c_ucs4_char_am_as(a) + if(any(a/=ref_c_ucs4_char_lm)) stop 366 + a = ref_c_ucs4_char_lm + call f_check_c_ucs4_char_am_ar(a) + if(any(a/=ref_c_ucs4_char_lm)) stop 367 + a = ref_c_ucs4_char_lm + call c_check_c_ucs4_char_am_ar(a) + if(any(a/=ref_c_ucs4_char_lm)) stop 368 + a = ref_c_ucs4_char_lm + p => a + call f_check_c_ucs4_char_dm_as(p) + if(.not.associated(p)) stop 369 + if(.not.associated(p, a)) stop 370 + if(any(p/=ref_c_ucs4_char_lm)) stop 371 + if(any(a/=ref_c_ucs4_char_lm)) stop 372 + a = ref_c_ucs4_char_lm + p => a + call c_check_c_ucs4_char_dm_as(p) + if(.not.associated(p)) stop 373 + if(.not.associated(p, a)) stop 374 + if(any(p/=ref_c_ucs4_char_lm)) stop 375 + if(any(a/=ref_c_ucs4_char_lm)) stop 376 + a = ref_c_ucs4_char_lm + p => a + call f_check_c_ucs4_char_dm_ar(p) + if(.not.associated(p)) stop 377 + if(.not.associated(p, a)) stop 378 + if(any(p/=ref_c_ucs4_char_lm)) stop 379 + if(any(a/=ref_c_ucs4_char_lm)) stop 380 + a = ref_c_ucs4_char_lm + p => a + call c_check_c_ucs4_char_dm_ar(p) + if(.not.associated(p)) stop 381 + if(.not.associated(p, a)) stop 382 + if(any(p/=ref_c_ucs4_char_lm)) stop 383 + if(any(a/=ref_c_ucs4_char_lm)) stop 384 + return + end subroutine check_c_ucs4_char_lm + + subroutine f_check_c_ucs4_char_cm_as(a) + character(kind=c_ucs4_char, len=m), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 385 + if(k/=4_c_signed_char) stop 386 + if(n/=m) stop 387 + if(int(k, kind=c_size_t)/=e) stop 388 + if(t/=CFI_type_ucs4_char) stop 389 + if(any(a/=ref_c_ucs4_char_lm)) stop 390 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_ucs4_char_lm)) stop 391 + return + end subroutine f_check_c_ucs4_char_cm_as + + subroutine c_check_c_ucs4_char_cm_as(a) bind(c) + character(kind=c_ucs4_char, len=m), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 392 + if(k/=4_c_signed_char) stop 393 + if(n/=m) stop 394 + if(int(k, kind=c_size_t)/=e) stop 395 + if(t/=CFI_type_ucs4_char) stop 396 + if(any(a/=ref_c_ucs4_char_lm)) stop 397 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_ucs4_char_lm)) stop 398 + return + end subroutine c_check_c_ucs4_char_cm_as + + subroutine f_check_c_ucs4_char_cm_ar(a) + character(kind=c_ucs4_char, len=m), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 399 + if(k/=4_c_signed_char) stop 400 + if(n/=m) stop 401 + if(int(k, kind=c_size_t)/=e) stop 402 + if(t/=CFI_type_ucs4_char) stop 403 + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_lm)) stop 404 + rank default + stop 405 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_lm)) stop 406 + rank default + stop 407 + end select + return + end subroutine f_check_c_ucs4_char_cm_ar + + subroutine c_check_c_ucs4_char_cm_ar(a) bind(c) + character(kind=c_ucs4_char, len=m), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 408 + if(k/=4_c_signed_char) stop 409 + if(n/=m) stop 410 + if(int(k, kind=c_size_t)/=e) stop 411 + if(t/=CFI_type_ucs4_char) stop 412 + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_lm)) stop 413 + rank default + stop 414 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_lm)) stop 415 + rank default + stop 416 + end select + return + end subroutine c_check_c_ucs4_char_cm_ar + + subroutine f_check_c_ucs4_char_am_as(a) + character(kind=c_ucs4_char, len=*), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 417 + if(k/=4_c_signed_char) stop 418 + if(n/=m) stop 419 + if(int(k, kind=c_size_t)/=e) stop 420 + if(t/=CFI_type_ucs4_char) stop 421 + if(any(a/=ref_c_ucs4_char_lm)) stop 422 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_ucs4_char_lm)) stop 423 + return + end subroutine f_check_c_ucs4_char_am_as + + subroutine c_check_c_ucs4_char_am_as(a) bind(c) + character(kind=c_ucs4_char, len=*), intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 424 + if(k/=4_c_signed_char) stop 425 + if(n/=m) stop 426 + if(int(k, kind=c_size_t)/=e) stop 427 + if(t/=CFI_type_ucs4_char) stop 428 + if(any(a/=ref_c_ucs4_char_lm)) stop 429 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_ucs4_char_lm)) stop 430 + return + end subroutine c_check_c_ucs4_char_am_as + + subroutine f_check_c_ucs4_char_am_ar(a) + character(kind=c_ucs4_char, len=*), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 431 + if(k/=4_c_signed_char) stop 432 + if(n/=m) stop 433 + if(int(k, kind=c_size_t)/=e) stop 434 + if(t/=CFI_type_ucs4_char) stop 435 + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_lm)) stop 436 + rank default + stop 437 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_lm)) stop 438 + rank default + stop 439 + end select + return + end subroutine f_check_c_ucs4_char_am_ar + + subroutine c_check_c_ucs4_char_am_ar(a) bind(c) + character(kind=c_ucs4_char, len=*), intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 440 + if(k/=4_c_signed_char) stop 441 + if(n/=m) stop 442 + if(int(k, kind=c_size_t)/=e) stop 443 + if(t/=CFI_type_ucs4_char) stop 444 + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_lm)) stop 445 + rank default + stop 446 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_lm)) stop 447 + rank default + stop 448 + end select + return + end subroutine c_check_c_ucs4_char_am_ar + + subroutine f_check_c_ucs4_char_dm_as(a) + character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 449 + if(k/=4_c_signed_char) stop 450 + if(n/=m) stop 451 + if(int(k, kind=c_size_t)/=e) stop 452 + if(t/=CFI_type_ucs4_char) stop 453 + if(any(a/=ref_c_ucs4_char_lm)) stop 454 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_ucs4_char_lm)) stop 455 + return + end subroutine f_check_c_ucs4_char_dm_as + + subroutine c_check_c_ucs4_char_dm_as(a) bind(c) + character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(:) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 456 + if(k/=4_c_signed_char) stop 457 + if(n/=m) stop 458 + if(int(k, kind=c_size_t)/=e) stop 459 + if(t/=CFI_type_ucs4_char) stop 460 + if(any(a/=ref_c_ucs4_char_lm)) stop 461 + call check_tk_as(a, t, k, e, n) + if(any(a/=ref_c_ucs4_char_lm)) stop 462 + return + end subroutine c_check_c_ucs4_char_dm_as + + subroutine f_check_c_ucs4_char_dm_ar(a) + character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 463 + if(k/=4_c_signed_char) stop 464 + if(n/=m) stop 465 + if(int(k, kind=c_size_t)/=e) stop 466 + if(t/=CFI_type_ucs4_char) stop 467 + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_lm)) stop 468 + rank default + stop 469 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_lm)) stop 470 + rank default + stop 471 + end select + return + end subroutine f_check_c_ucs4_char_dm_ar + + subroutine c_check_c_ucs4_char_dm_ar(a) bind(c) + character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(..) + ! + integer(kind=c_int16_t) :: t + integer(kind=c_signed_char) :: k + integer(kind=c_size_t) :: e, n + ! + k = kind(a) + n = len(a, kind=kind(e)) + e = storage_size(a, kind=kind(e))/(b*m) + t = cfi_encode_type(CFI_type_Character, k) + if(k<=0_c_signed_char) stop 472 + if(k/=4_c_signed_char) stop 473 + if(n/=m) stop 474 + if(int(k, kind=c_size_t)/=e) stop 475 + if(t/=CFI_type_ucs4_char) stop 476 + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_lm)) stop 477 + rank default + stop 478 + end select + call check_tk_ar(a, t, k, e, n) + select rank(a) + rank(1) + if(any(a/=ref_c_ucs4_char_lm)) stop 479 + rank default + stop 480 + end select + return + end subroutine c_check_c_ucs4_char_dm_ar + +end module iso_check_m + +program main_p + + use :: iso_check_m, only: & + check_c_char_l1, & + check_c_char_lm, & + check_c_ucs4_char_l1, & + check_c_ucs4_char_lm + + implicit none + + call check_c_char_l1() + call check_c_char_lm() + ! See PR100907 + !call check_c_ucs4_char_l1() + !call check_c_ucs4_char_lm() + stop + +end program main_p + +!! Local Variables: +!! mode: f90 +!! End: + diff --git a/gcc/testsuite/gfortran.dg/PR100914.f90 b/gcc/testsuite/gfortran.dg/PR100914.f90 index d8057fd..8588157 100644 --- a/gcc/testsuite/gfortran.dg/PR100914.f90 +++ b/gcc/testsuite/gfortran.dg/PR100914.f90 @@ -1,5 +1,5 @@ ! Fails on x86 targets where sizeof(long double) == 16. -! { dg-do run { xfail { { x86_64*-*-* i?86*-*-* } && longdouble128 } } } +! { dg-do run } ! { dg-additional-sources PR100914.c } ! { dg-require-effective-target fortran_real_c_float128 } ! { dg-additional-options "-Wno-pedantic" } diff --git a/gcc/testsuite/gfortran.dg/PR100915.c b/gcc/testsuite/gfortran.dg/PR100915.c index 5b219b3..4eaf82a 100644 --- a/gcc/testsuite/gfortran.dg/PR100915.c +++ b/gcc/testsuite/gfortran.dg/PR100915.c @@ -67,7 +67,7 @@ check_fn (const CFI_cdesc_t *restrict auxp, const CFI_type_t type, const signed /* */ assert (auxp->type==type); ityp = _CFI_decode_type(auxp->type); - assert (ityp == CFI_type_cptr); + assert (ityp == CFI_type_cfunptr); iknd = _CFI_decode_kind(auxp->type); assert (_CFI_decode_type(type)==ityp); assert (kind==iknd); diff --git a/gcc/testsuite/gfortran.dg/PR100915.f90 b/gcc/testsuite/gfortran.dg/PR100915.f90 index 083565e..64a2a88 100644 --- a/gcc/testsuite/gfortran.dg/PR100915.f90 +++ b/gcc/testsuite/gfortran.dg/PR100915.f90 @@ -14,7 +14,7 @@ module isof_m private public :: & - CFI_type_cptr + CFI_type_cptr, CFI_type_cfunptr public :: & check_fn_as, & @@ -33,6 +33,7 @@ module isof_m ! Intrinsic types. Their kind number defines their storage size. */ integer(kind=c_signed_char), parameter :: CFI_type_cptr = 7 + integer(kind=c_signed_char), parameter :: CFI_type_cfunptr = 8 interface subroutine check_fn_as(a, t, k, e, n) & @@ -99,7 +100,7 @@ module iso_check_m c_funptr, c_funloc, c_associated use :: isof_m, only: & - CFI_type_cptr + CFI_type_cptr, CFI_type_cfunptr use :: isof_m, only: & check_fn_as, & @@ -155,7 +156,7 @@ contains ! k = 0 e = storage_size(a)/b - t = cfi_encode_type(CFI_type_cptr, k) + t = cfi_encode_type(CFI_type_cfunptr, k) ! Assumes 64-bit target. ! if(e/=8) stop 5 do i = 1, n @@ -176,7 +177,7 @@ contains ! k = 0 e = storage_size(a)/b - t = cfi_encode_type(CFI_type_cptr, k) + t = cfi_encode_type(CFI_type_cfunptr, k) ! Assumes 64-bit target. ! if(e/=8) stop 8 do i = 1, n @@ -198,7 +199,7 @@ contains ! k = 0 e = storage_size(a)/b - t = cfi_encode_type(CFI_type_cptr, k) + t = cfi_encode_type(CFI_type_cfunptr, k) ! Assumes 64-bit target. ! if(e/=8) stop 11 select rank(a) @@ -229,7 +230,7 @@ contains ! k = 0 e = storage_size(a)/b - t = cfi_encode_type(CFI_type_cptr, k) + t = cfi_encode_type(CFI_type_cfunptr, k) ! Assumes 64-bit target. ! if(e/=8) stop 16 select rank(a) diff --git a/gcc/testsuite/gfortran.dg/PR93963.f90 b/gcc/testsuite/gfortran.dg/PR93963.f90 index 4e1b06f..6769d7f 100644 --- a/gcc/testsuite/gfortran.dg/PR93963.f90 +++ b/gcc/testsuite/gfortran.dg/PR93963.f90 @@ -1,8 +1,11 @@ ! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } ! ! Test the fix for PR93963 ! +module m +contains function rank_p(this) result(rnk) bind(c) use, intrinsic :: iso_c_binding, only: c_int @@ -97,27 +100,60 @@ function rank_a(this) result(rnk) bind(c) return end function rank_a -program selr_p - +function rank_o(this) result(rnk) bind(c) use, intrinsic :: iso_c_binding, only: c_int implicit none + + integer(kind=c_int), intent(in) :: this(..) + integer(kind=c_int) :: rnk + + select rank(this) + rank(0) + rnk = 0 + rank(1) + rnk = 1 + rank(2) + rnk = 2 + rank(3) + rnk = 3 + rank(4) + rnk = 4 + rank(5) + rnk = 5 + rank(6) + rnk = 6 + rank(7) + rnk = 7 + rank(8) + rnk = 8 + rank(9) + rnk = 9 + rank(10) + rnk = 10 + rank(11) + rnk = 11 + rank(12) + rnk = 12 + rank(13) + rnk = 13 + rank(14) + rnk = 14 + rank(15) + rnk = 15 + rank default + rnk = -1000 + end select + return +end function rank_o + +end module m + +program selr_p + use m + use, intrinsic :: iso_c_binding, only: c_int - interface - function rank_p(this) result(rnk) bind(c) - use, intrinsic :: iso_c_binding, only: c_int - integer(kind=c_int), pointer, intent(in) :: this(..) - integer(kind=c_int) :: rnk - end function rank_p - end interface - - interface - function rank_a(this) result(rnk) bind(c) - use, intrinsic :: iso_c_binding, only: c_int - integer(kind=c_int), allocatable, intent(in) :: this(..) - integer(kind=c_int) :: rnk - end function rank_a - end interface + implicit none integer(kind=c_int), parameter :: siz = 7 integer(kind=c_int), parameter :: rnk = 1 @@ -139,12 +175,23 @@ program selr_p irnk = rank_p(intp) if (irnk /= rnk) stop 5 if (irnk /= rank(intp)) stop 6 + irnk = rank_o(intp) + if (irnk /= rnk) stop 7 + if (irnk /= rank(intp)) stop 8 deallocate(intp) nullify(intp) ! allocate(inta(siz)) - if (irnk /= rnk) stop 7 - if (irnk /= rank(inta)) stop 8 + irnk = rank_a(inta) + if (irnk /= rnk) stop 9 + if (irnk /= rank(inta)) stop 10 + irnk = rank_o(inta) + if (irnk /= rnk) stop 11 + if (irnk /= rank(inta)) stop 12 deallocate(inta) end program selr_p + +! Special code for assumed rank - but only if not allocatable/pointer +! Thus, expect it only once for subroutine rank_o but not for rank_a or rank_p +! { dg-final { scan-tree-dump-times "ubound != -1" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/PR94110.f90 b/gcc/testsuite/gfortran.dg/PR94110.f90 index 9ec70ec..4e43332 100644 --- a/gcc/testsuite/gfortran.dg/PR94110.f90 +++ b/gcc/testsuite/gfortran.dg/PR94110.f90 @@ -9,6 +9,16 @@ program asa_p integer, parameter :: n = 7 + type t + end type t + + interface + subroutine fc2 (x) + import :: t + class(t), pointer, intent(in) :: x(..) + end subroutine + end interface + integer :: p(n) integer :: s @@ -84,5 +94,10 @@ contains return end function sum_p_ar + subroutine sub1(y) + type(t), target :: y(*) + call fc2 (y) ! { dg-error "Actual argument for .x. cannot be an assumed-size array" } + end subroutine sub1 + end program asa_p diff --git a/gcc/testsuite/gfortran.dg/PR94289.f90 b/gcc/testsuite/gfortran.dg/PR94289.f90 new file mode 100644 index 0000000..4f17d97 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR94289.f90 @@ -0,0 +1,168 @@ +! { dg-do run } +! +! Testcase for PR 94289 +! +! - if the dummy argument is a pointer/allocatable, it has the same +! bounds as the dummy argument +! - if is is nonallocatable nonpointer, the lower bounds are [1, 1, 1]. + +module bounds_m + + implicit none + + private + public :: & + lb, ub + + public :: & + bnds_p, & + bnds_a, & + bnds_e + + integer, parameter :: lb1 = 3 + integer, parameter :: lb2 = 5 + integer, parameter :: lb3 = 9 + integer, parameter :: ub1 = 4 + integer, parameter :: ub2 = 50 + integer, parameter :: ub3 = 11 + integer, parameter :: ex1 = ub1 - lb1 + 1 + integer, parameter :: ex2 = ub2 - lb2 + 1 + integer, parameter :: ex3 = ub3 - lb3 + 1 + + integer, parameter :: lf(*) = [1,1,1] + integer, parameter :: lb(*) = [lb1,lb2,lb3] + integer, parameter :: ub(*) = [ub1,ub2,ub3] + integer, parameter :: ex(*) = [ex1,ex2,ex3] + +contains + + subroutine bounds(a, lb, ub) + integer, pointer, intent(in) :: a(..) + integer, intent(in) :: lb(3) + integer, intent(in) :: ub(3) + + integer :: ex(3) + + ex = max(ub-lb+1, 0) + if(any(lbound(a)/=lb)) stop 101 + if(any(ubound(a)/=ub)) stop 102 + if(any( shape(a)/=ex)) stop 103 + return + end subroutine bounds + + subroutine bnds_p(this) + integer, pointer, intent(in) :: this(..) + + if(any(lbound(this)/=lb)) stop 1 + if(any(ubound(this)/=ub)) stop 2 + if(any( shape(this)/=ex)) stop 3 + call bounds(this, lb, ub) + return + end subroutine bnds_p + + subroutine bnds_a(this) + integer, allocatable, target, intent(in) :: this(..) + + if(any(lbound(this)/=lb)) stop 4 + if(any(ubound(this)/=ub)) stop 5 + if(any( shape(this)/=ex)) stop 6 + call bounds(this, lb, ub) + return + end subroutine bnds_a + + subroutine bnds_e(this) + integer, target, intent(in) :: this(..) + + if(any(lbound(this)/=lf)) stop 7 + if(any(ubound(this)/=ex)) stop 8 + if(any( shape(this)/=ex)) stop 9 + call bounds(this, lf, ex) + return + end subroutine bnds_e + +end module bounds_m + +program bounds_p + + use, intrinsic :: iso_c_binding, only: c_int + + use bounds_m + + implicit none + + integer, parameter :: fpn = 1 + integer, parameter :: fan = 2 + integer, parameter :: fon = 3 + + integer :: i + + do i = fpn, fon + call test_p(i) + end do + do i = fpn, fon + call test_a(i) + end do + do i = fpn, fon + call test_e(i) + end do + stop + +contains + + subroutine test_p(t) + integer, intent(in) :: t + + integer, pointer :: a(:,:,:) + + allocate(a(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3))) + select case(t) + case(fpn) + call bnds_p(a) + case(fan) + case(fon) + call bnds_e(a) + case default + stop + end select + deallocate(a) + return + end subroutine test_p + + subroutine test_a(t) + integer, intent(in) :: t + + integer, allocatable, target :: a(:,:,:) + + allocate(a(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3))) + select case(t) + case(fpn) + call bnds_p(a) + case(fan) + call bnds_a(a) + case(fon) + call bnds_e(a) + case default + stop + end select + deallocate(a) + return + end subroutine test_a + + subroutine test_e(t) + integer, intent(in) :: t + + integer, target :: a(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3)) + + select case(t) + case(fpn) + call bnds_p(a) + case(fan) + case(fon) + call bnds_e(a) + case default + stop + end select + return + end subroutine test_e + +end program bounds_p diff --git a/gcc/testsuite/gfortran.dg/PR95196.f90 b/gcc/testsuite/gfortran.dg/PR95196.f90 new file mode 100644 index 0000000..14333e4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR95196.f90 @@ -0,0 +1,83 @@ +! { dg-do run } + +program rnk_p + + implicit none + + integer, parameter :: n = 10 + integer, parameter :: m = 5 + integer, parameter :: s = 4 + integer, parameter :: l = 4 + integer, parameter :: u = s+l-1 + + integer :: a(n) + integer :: b(n,n) + integer :: c(n,n,n) + integer :: r(s*s*s) + integer :: i + + a = reshape([(i, i=1,n)], [n]) + b = reshape([(i, i=1,n*n)], [n,n]) + c = reshape([(i, i=1,n*n*n)], [n,n,n]) + r(1:s) = a(l:u) + call rnk_s(a(l:u), r(1:s)) + r(1:s*s) = reshape(b(l:u,l:u), [s*s]) + call rnk_s(b(l:u,l:u), r(1:s*s)) + r = reshape(c(l:u,l:u,l:u), [s*s*s]) + call rnk_s(c(l:u,l:7,l:u), r) + stop + +contains + + subroutine rnk_s(a, b) + integer, intent(in) :: a(..) + integer, intent(in) :: b(:) + + !integer :: l(rank(a)), u(rank(a)) does not work due to Bug 94048 + integer, allocatable :: lb(:), ub(:) + integer :: i, j, k, l + + lb = lbound(a) + ub = ubound(a) + select rank(a) + rank(1) + if(any(lb/=lbound(a))) stop 11 + if(any(ub/=ubound(a))) stop 12 + if(size(a)/=size(b)) stop 13 + do i = 1, size(a) + if(a(i)/=b(i)) stop 14 + end do + rank(2) + if(any(lb/=lbound(a))) stop 21 + if(any(ub/=ubound(a))) stop 22 + if(size(a)/=size(b)) stop 23 + k = 0 + do j = 1, size(a, dim=2) + do i = 1, size(a, dim=1) + k = k + 1 + if(a(i,j)/=b(k)) stop 24 + end do + end do + rank(3) + if(any(lb/=lbound(a))) stop 31 + if(any(ub/=ubound(a))) stop 32 + if(size(a)/=size(b)) stop 33 + l = 0 + do k = 1, size(a, dim=3) + do j = 1, size(a, dim=2) + do i = 1, size(a, dim=1) + l = l + 1 + ! print *, a(i,j,k), b(l) + if(a(i,j,k)/=b(l)) stop 34 + end do + end do + end do + rank default + stop 171 + end select + deallocate(lb, ub) + return + end subroutine rnk_s + +end program rnk_p + diff --git a/gcc/testsuite/gfortran.dg/associate_3.f03 b/gcc/testsuite/gfortran.dg/associate_3.f03 index da7bec9..dfd5a99 100644 --- a/gcc/testsuite/gfortran.dg/associate_3.f03 +++ b/gcc/testsuite/gfortran.dg/associate_3.f03 @@ -34,4 +34,4 @@ PROGRAM main INTEGER :: b ! { dg-error "Unexpected data declaration statement" } END ASSOCIATE END PROGRAM main ! { dg-error "Expecting END ASSOCIATE" } -! { dg-excess-errors "Unexpected end of file" } +! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_24.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_24.f90 new file mode 100644 index 0000000..d91b5ec --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_rank_24.f90 @@ -0,0 +1,137 @@ +! { dg-do run } +! { dg-additional-options "-fcheck=all" } +module m + implicit none (external, type) +contains + subroutine cl(x) + class(*) :: x(..) + if (rank(x) /= 1) stop 1 + if (ubound(x, dim=1) /= -1) stop 2 + select rank (x) + rank (1) + select type (x) + type is (integer) + ! ok + class default + stop 3 + end select + end select + end subroutine + subroutine tp(x) + type(*) :: x(..) + if (rank(x) /= 1) stop 4 + if (ubound(x, dim=1) /= -1) stop 5 + end subroutine + + subroutine foo (ccc, ddd, sss, ttt) + integer :: sss(*), ttt(*) + class(*) :: ccc(*), ddd(*) + call cl(sss) + call tp(ttt) + call cl(ccc) + call tp(ddd) + end + + subroutine foo2 (ccc, ddd, sss, ttt, ispresent) + integer :: sss(*), ttt(*) + class(*) :: ccc(*), ddd(*) + optional :: ccc, ddd, sss, ttt + logical, value :: ispresent + if (present(ccc) .neqv. ispresent) stop 6 + if (present(ccc)) then + call cl(sss) + call tp(ttt) + call cl(ccc) + call tp(ddd) + end if + end +end + +module m2 + implicit none (external, type) +contains + subroutine cl2(x) + class(*), allocatable :: x(..) + if (rank(x) /= 1) stop 7 + if (.not. allocated (x)) & + return + if (lbound(x, dim=1) /= -2) stop 8 + if (ubound(x, dim=1) /= -1) stop 9 + if (size (x, dim=1) /= 2) stop 10 + select rank (x) + rank (1) + select type (x) + type is (integer) + ! ok + class default + stop 11 + end select + end select + end subroutine + + subroutine tp2(x) + class(*), pointer :: x(..) + if (rank(x) /= 1) stop 12 + if (.not. associated (x)) & + return + if (lbound(x, dim=1) /= -2) stop 13 + if (ubound(x, dim=1) /= -1) stop 14 + if (size (x, dim=1) /= 2) stop 15 + select rank (x) + rank (1) + select type (x) + type is (integer) + ! ok + class default + stop 16 + end select + end select + end subroutine + + subroutine foo3 (ccc, ddd, sss, ttt) + class(*), allocatable :: sss(:) + class(*), pointer :: ttt(:) + class(*), allocatable :: ccc(:) + class(*), pointer :: ddd(:) + call cl2(sss) + call tp2(ttt) + call cl2(ccc) + call tp2(ddd) + end + + subroutine foo4 (ccc, ddd, sss, ttt, ispresent) + class(*), allocatable, optional :: sss(:) + class(*), pointer, optional :: ttt(:) + class(*), allocatable, optional :: ccc(:) + class(*), pointer, optional :: ddd(:) + logical, value :: ispresent + if (present(ccc) .neqv. ispresent) stop 17 + if (present(ccc)) then + call cl2(sss) + call tp2(ttt) + call cl2(ccc) + call tp2(ddd) + end if + end +end + +use m +use m2 +implicit none (external, type) +integer :: a(1),b(1),c(1),d(1) +class(*),allocatable :: aa(:),cc(:) +class(*),pointer :: bb(:),dd(:) +call foo (a,b,c,d) +call foo2 (a,b,c,d, .true.) +call foo2 (ispresent=.false.) + +nullify(bb,dd) +call foo3 (aa,bb,cc,dd) +call foo4 (aa,bb,cc,dd, .true.) +call foo4 (ispresent=.false.) +allocate(integer :: aa(-2:-1), bb(-2:-1), cc(-2:-1), dd(-2:-1)) +call foo3 (aa,bb,cc,dd) +call foo4 (aa,bb,cc,dd, .true.) +call foo4 (ispresent=.false.) +deallocate(aa,bb,cc,dd) +end diff --git a/gcc/testsuite/gfortran.dg/assumed_type_12.f90 b/gcc/testsuite/gfortran.dg/assumed_type_12.f90 new file mode 100644 index 0000000..ce6d0bc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_type_12.f90 @@ -0,0 +1,34 @@ +! PR fortran/102086 + +implicit none (type, external) +contains +subroutine as(a) + type(*) :: a(:,:) +end +subroutine ar(b) + type(*) :: b(..) +end +subroutine bar(x,y) + type(*) :: x + type(*) :: y(3,*) + call as(x) ! { dg-error "Rank mismatch in argument 'a' at .1. \\(rank-2 and scalar\\)" } + call ar(x) ! { dg-error "Assumed-type actual argument at .1. corresponding to assumed-rank dummy argument 'b' must be assumed-shape or assumed-rank" } + call ar(y) ! { dg-error "Assumed-type actual argument at .1. corresponding to assumed-rank dummy argument 'b' must be assumed-shape or assumed-rank" } + call as(y(1,3)) ! { dg-error "Assumed-type variable y at .1. shall not have a subobject reference" } + call ar(y(1,3)) ! { dg-error "Assumed-type variable y at .1. shall not have a subobject reference" } + call as(y(1:1,3:3)) ! { dg-error "Assumed-type variable y at .1. shall not have a subobject reference" } + call ar(y(1:1,3:3)) ! { dg-error "Assumed-type variable y at .1. shall not have a subobject reference" } +end + +subroutine okayish(x,y,z) + type(*) :: x(:) + type(*) :: y(:,:) + type(*) :: z(..) + call as(x) ! { dg-error "Rank mismatch in argument 'a' at .1. \\(rank-2 and rank-1\\)" } + call as(y) + call as(z) ! { dg-error "The assumed-rank array at .1. requires that the dummy argument 'a' has assumed-rank" } + call ar(x) + call ar(y) + call ar(z) +end +end diff --git a/gcc/testsuite/gfortran.dg/assumed_type_13.c b/gcc/testsuite/gfortran.dg/assumed_type_13.c new file mode 100644 index 0000000..d602d35 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_type_13.c @@ -0,0 +1,26 @@ +#include <ISO_Fortran_binding.h> + +void +test_c (CFI_cdesc_t *x, size_t n, int num) +{ + if (!x->base_addr) + __builtin_abort (); + if (x->version != CFI_VERSION) + __builtin_abort (); + if (x->rank != 1) + __builtin_abort (); + if (x->attribute != CFI_attribute_other) + __builtin_abort (); + if (x->dim[0].lower_bound != 0) + __builtin_abort (); + if (x->dim[0].extent != 3) + __builtin_abort (); + + if (x->elem_len != n || x->dim[0].sm != n) + __builtin_abort (); + + if (num == 1 && x->type != CFI_type_int16_t) + __builtin_abort (); + if (num == 2 && x->type != CFI_type_double_Complex) + __builtin_abort (); +} diff --git a/gcc/testsuite/gfortran.dg/assumed_type_13.f90 b/gcc/testsuite/gfortran.dg/assumed_type_13.f90 new file mode 100644 index 0000000..da167ae --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_type_13.f90 @@ -0,0 +1,66 @@ +! { dg-do run } +! { dg-additional-sources assumed_type_13.c } + +use iso_c_binding, only: c_size_t, c_int +implicit none (type, external) + +interface + subroutine test_c (x, n, num) bind (C) + import :: c_size_t, c_int + integer(c_size_t), value :: n + integer(c_int), value :: num + type(*) :: x(:) + end subroutine test_c +end interface + +complex(8) :: b(3) + +call test_c ([1_2, 2_2, 3_2], sizeof(1_2), num=1) +call test_c (b, sizeof(b(1)), num=2) +call outer_bc ([1_2, 2_2, 3_2], sizeof(1_2), num=1) +call outer_bc (b, sizeof(b(1)), num=2) +call outer_f ([1_2, 2_2, 3_2], sizeof(1_2), num=1) +call outer_f (b, sizeof(b(1)), num=2) + +contains + +subroutine outer_bc (x, n, num) bind(C) + integer(c_size_t), value :: n + integer(c_int), value :: num + type(*) :: x(:) + ! print *,sizeof(x)/size(x), n + if (sizeof(x)/size(x) /= n) error stop 1 + call inner_bc (x, n, num) + call inner_f (x, n, num) + call test_c (x, n, num) +end + +subroutine outer_f (x, n, num) + integer(c_size_t), value :: n + integer(c_int), value :: num + type(*) :: x(:) + ! print *,sizeof(x)/size(x), n + if (sizeof(x)/size(x) /= n) error stop 1 + call inner_f (x, n, num) + call inner_bc (x, n, num) + call test_c (x, n, num) +end + +subroutine inner_bc(x, n, num) bind(C) + integer(c_size_t), value :: n + integer(c_int), value :: num + type(*) :: x(:) + ! print *,sizeof(x)/size(x), n + if (sizeof(x)/size(x) /= n) error stop 2 + call test_c (x, n, num) +end + +subroutine inner_f(x, n, num) + integer(c_size_t), value :: n + integer(c_int), value :: num + type(*) :: x(:) + ! print *,sizeof(x)/size(x), n + if (sizeof(x)/size(x) /= n) error stop 3 + call test_c (x, n, num) +end +end diff --git a/gcc/testsuite/gfortran.dg/bind-c-char-descr.f90 b/gcc/testsuite/gfortran.dg/bind-c-char-descr.f90 new file mode 100644 index 0000000..8829fd1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind-c-char-descr.f90 @@ -0,0 +1,123 @@ +! PR fortran/92482 +! +! Contributed by José Rui Faustino de Sousa +! + +program strp_p + + use, intrinsic :: iso_c_binding, only: & + c_char + + implicit none + + integer, parameter :: l = 3 + + character(len=l, kind=c_char), target :: str + character(len=:, kind=c_char), pointer :: strp_1 + character(len=l, kind=c_char), pointer :: strp_2 + + str = "abc" + nullify(strp_1, strp_2) + strp_1 => str + strp_2 => str + if (len(str) /= 3 .or. str /= "abc") stop 1 + if (len(strp_1) /= 3 .or. strp_1 /= "abc") stop 2 + if (len(strp_2) /= 3 .or. strp_2 /= "abc") stop 3 + call strg_print_0("abc") + call strg_print_0(str) + call strg_print_0(strp_1) + call strg_print_0(strp_2) + call strg_print_0_c("abc") + call strg_print_0_c(str) + call strg_print_0_c(strp_1) + call strg_print_0_c(strp_2) + call strg_print_1(strp_1) + call strg_print_1_c(strp_1) + + call strg_print_2("abc") + call strg_print_2(str) + call strg_print_2(strp_1) + call strg_print_2(strp_2) + + call strg_print_2_c("abc") + call strg_print_2_c(str) + call strg_print_2_c(strp_1) + call strg_print_2_c(strp_2) + +contains + + subroutine strg_print_0 (this) + character(len=*, kind=c_char), target, intent(in) :: this + + if (len (this) /= 3) stop 10 + if (this /= "abc") stop 11 + end subroutine strg_print_0 + + subroutine strg_print_0_c (this) bind(c) + character(len=*, kind=c_char), target, intent(in) :: this + + if (len (this) /= 3) stop 10 + if (this /= "abc") stop 11 + end subroutine strg_print_0_c + + subroutine strg_print_1 (this) bind(c) + character(len=:, kind=c_char), pointer, intent(in) :: this + character(len=:), pointer :: strn + + if (.not. associated (this)) stop 20 + if (len (this) /= 3) stop 21 + if (this /= "abc") stop 22 + strn => this + if (.not. associated (strn)) stop 23 + if(associated(strn))then + if (len (this) /= 3) stop 24 + if (this /= "abc") stop 25 + end if + end subroutine strg_print_1 + + subroutine strg_print_1_c (this) bind(c) + character(len=:, kind=c_char), pointer, intent(in) :: this + character(len=:), pointer :: strn + + if (.not. associated (this)) stop 20 + if (len (this) /= 3) stop 21 + if (this /= "abc") stop 22 + strn => this + if (.not. associated (strn)) stop 23 + if(associated(strn))then + if (len (this) /= 3) stop 24 + if (this /= "abc") stop 25 + end if + end subroutine strg_print_1_c + + subroutine strg_print_2(this) + use, intrinsic :: iso_c_binding, only: & + c_loc, c_f_pointer + + type(*), target, intent(in) :: this(..) + character(len=l), pointer :: strn + + call c_f_pointer(c_loc(this), strn) + if (.not. associated (strn)) stop 30 + if (associated(strn)) then + if (len (strn) /= 3) stop 31 + if (strn /= "abc") stop 32 + end if + end subroutine strg_print_2 + + subroutine strg_print_2_c(this) bind(c) + use, intrinsic :: iso_c_binding, only: & + c_loc, c_f_pointer + + type(*), target, intent(in) :: this(..) + character(len=l), pointer :: strn + + call c_f_pointer(c_loc(this), strn) + if (.not. associated (strn)) stop 40 + if(associated(strn))then + if (len (strn) /= 3) stop 41 + if (strn /= "abc") stop 42 + end if + end subroutine strg_print_2_c + +end program strp_p diff --git a/gcc/testsuite/gfortran.dg/bind-c-contiguous-1.c b/gcc/testsuite/gfortran.dg/bind-c-contiguous-1.c new file mode 100644 index 0000000..06bbd6f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind-c-contiguous-1.c @@ -0,0 +1,345 @@ +#include <ISO_Fortran_binding.h> +#include <stdbool.h> +#include <string.h> + +struct loc_t { + intptr_t x, y, z; +}; + +typedef struct loc_t (*ftn_fn) (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_size_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_size_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_expl_size_f (CFI_cdesc_t *,CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_expl_size_in_f (CFI_cdesc_t *,CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_rank_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_rank_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_rank_cont_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_rank_cont_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_shape_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_shape_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_shape_cont_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_shape_cont_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); + +static void +basic_check(CFI_cdesc_t *x, bool is_cont) +{ + if (!x->base_addr) + __builtin_abort (); + if (x->elem_len != 3*sizeof(char)) + __builtin_abort (); + if (x->version != CFI_VERSION) + __builtin_abort (); + if (x->rank != 1) + __builtin_abort (); + if (x->attribute != CFI_attribute_other) + __builtin_abort (); + if (x->type != CFI_type_char) + __builtin_abort (); + if (x->dim[0].lower_bound != 0) + __builtin_abort (); + if (x->dim[0].extent != 3) + __builtin_abort (); + if (CFI_is_contiguous (x) != (x->elem_len == x->dim[0].sm)) + __builtin_abort (); + if (is_cont != CFI_is_contiguous (x)) + __builtin_abort (); +} + +static void +print_str (void *p, size_t len) +{ + __builtin_printf ("DEBUG: >"); + for (size_t i = 0; i < len; ++i) + __builtin_printf ("%c", ((const char*) p)[i]); + __builtin_printf ("<\n"); +} + +static void +check_str (CFI_cdesc_t *x, const char *str, const CFI_index_t subscripts[]) +{ + /* Avoid checking for '\0'. */ + if (strncmp ((const char*) CFI_address (x, subscripts), str, strlen(str)) != 0) + __builtin_abort (); +} + +static void +set_str (CFI_cdesc_t *x, const char *str, const CFI_index_t subscripts[]) +{ + char *p = CFI_address (x, subscripts); + size_t len = strlen (str); + if (x->elem_len != len) + __builtin_abort (); + for (size_t i = 0; i < len; ++i) + p[i] = str[i]; +} + +static struct loc_t +do_call (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num, bool intent_in, ftn_fn fn, bool is_cont, bool fort_cont) +{ + const CFI_index_t zero[1] = { 0 }; + const CFI_index_t one[1] = { 1 }; + const CFI_index_t two[1] = { 2 }; + struct loc_t addr1, addr2; + if (k != 3) + __builtin_abort (); + basic_check (x, is_cont || num == 2); + basic_check (y, is_cont || num == 2); + basic_check (z, is_cont || num == 2); + if (!is_cont && num == 1) + { + check_str (x, "abc", zero); + check_str (x, "ghi", one); + check_str (x, "nop", two); + check_str (y, "abc", zero); + check_str (y, "ghi", one); + check_str (y, "nop", two); + check_str (z, "abc", zero); + check_str (z, "ghi", one); + check_str (z, "nop", two); + } + else if (num == 1) + { + if (strncmp ((const char*) x->base_addr, "abcghinop", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) y->base_addr, "abcghinop", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) z->base_addr, "abcghinop", 9) != 0) + __builtin_abort (); + } + else if (num == 2) + { + if (strncmp ((const char*) x->base_addr, "defghijlm", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) y->base_addr, "defghijlm", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) z->base_addr, "defghijlm", 9) != 0) + __builtin_abort (); + } + else + __builtin_abort (); + addr1.x = (intptr_t) x->base_addr; + addr1.y = (intptr_t) y->base_addr; + addr1.z = (intptr_t) z->base_addr; + addr2 = fn (x, y, z, 3, num); + if (!CFI_is_contiguous (x) && fort_cont) + { + /* Check for callee copy in/copy out. */ + if (addr1.x == addr2.x || addr1.x != (intptr_t) x->base_addr) + __builtin_abort (); + if (addr1.y == addr2.y || addr1.y != (intptr_t) y->base_addr) + __builtin_abort (); + if (addr1.z == addr2.z || addr1.z != (intptr_t) z->base_addr) + __builtin_abort (); + } + else + { + if (addr1.x != addr2.x || addr1.x != (intptr_t) x->base_addr) + __builtin_abort (); + if (addr1.y != addr2.y || addr1.y != (intptr_t) y->base_addr) + __builtin_abort (); + if (addr1.z != addr2.z || addr1.z != (intptr_t) z->base_addr) + __builtin_abort (); + } + // intent_in + if (intent_in && !is_cont && num == 1) + { + check_str (x, "abc", zero); + check_str (x, "ghi", one); + check_str (x, "nop", two); + check_str (y, "abc", zero); + check_str (y, "ghi", one); + check_str (y, "nop", two); + check_str (z, "abc", zero); + check_str (z, "ghi", one); + check_str (z, "nop", two); + } + else if (intent_in && num == 1) + { + if (strncmp ((const char*) x->base_addr, "abcghinop", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) y->base_addr, "abcghinop", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) z->base_addr, "abcghinop", 9) != 0) + __builtin_abort (); + } + else if (intent_in && num == 2) + { + if (strncmp ((const char*) x->base_addr, "defghijlm", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) y->base_addr, "defghijlm", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) z->base_addr, "defghijlm", 9) != 0) + __builtin_abort (); + } + else if (intent_in) + __builtin_abort (); + if (intent_in) + { + if (is_cont && num == 1) + { + /* Copy in - set the value to check that no copy out is done. */ + memcpy ((char*) x->base_addr, "123456789", 9); + memcpy ((char*) y->base_addr, "123456789", 9); + memcpy ((char*) z->base_addr, "123456789", 9); + } + return addr1; + } + // !intent_in + if (!is_cont && num == 1) + { + check_str (x, "ABC", zero); + check_str (x, "DEF", one); + check_str (x, "GHI", two); + check_str (y, "ABC", zero); + check_str (y, "DEF", one); + check_str (y, "GHI", two); + check_str (z, "ABC", zero); + check_str (z, "DEF", one); + check_str (z, "GHI", two); + } + else + { + if (strncmp ((const char*) x->base_addr, "ABCDEFGHI", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) y->base_addr, "ABCDEFGHI", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) z->base_addr, "ABCDEFGHI", 9) != 0) + __builtin_abort (); + } + return addr1; +} + +struct loc_t +char_assumed_size_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_assumed_size_f, true, false); +} + +struct loc_t +char_assumed_size_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_size_in_f, true, false); +} + +struct loc_t +char_expl_size_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_expl_size_f, true, false); +} + +struct loc_t +char_expl_size_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_expl_size_in_f, true, false); +} + +struct loc_t +char_assumed_rank_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_assumed_rank_f, false, false); +} + +struct loc_t +char_assumed_rank_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_rank_in_f, false, false); +} + +struct loc_t +char_assumed_rank_cont_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_assumed_rank_cont_f, true, false); +} + +struct loc_t +char_assumed_rank_cont_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_rank_cont_in_f, true, false); +} + +static void +reset_var (CFI_cdesc_t *x, int num) +{ + const CFI_index_t zero[1] = { 0 }; + const CFI_index_t one[1] = { 1 }; + const CFI_index_t two[1] = { 2 }; + + if (num == 1) + { + set_str (x, "abc", zero); + set_str (x, "ghi", one); + set_str (x, "nop", two); + } + else if (num == 2) + { + set_str (x, "def", zero); + set_str (x, "ghi", one); + set_str (x, "jlm", two); + } + else + __builtin_abort (); +} + +static void +reset_vars (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, int num) +{ + reset_var (x, num); + reset_var (y, num); + reset_var (z, num); +} + +struct loc_t +char_assumed_shape_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + /* Make use of having a noncontiguous argument to check that the callee + handles noncontiguous variables. */ + do_call (x, y, z, k, num, false, char_assumed_size_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, true, char_assumed_size_in_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, false, char_expl_size_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, true, char_expl_size_in_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, false, char_assumed_rank_cont_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, true, char_assumed_rank_cont_in_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, false, char_assumed_shape_cont_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, true, char_assumed_shape_cont_in_f, false, true); + /* Actual func call. */ + reset_vars (x, y, z, num); + return do_call (x, y, z, k, num, false, char_assumed_shape_f, false, false); +} + +struct loc_t +char_assumed_shape_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_shape_in_f, false, false); +} + +struct loc_t +char_assumed_shape_cont_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_assumed_shape_cont_f, true, false); +} + +struct loc_t +char_assumed_shape_cont_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_shape_cont_in_f, true, false); +} diff --git a/gcc/testsuite/gfortran.dg/bind-c-contiguous-1.f90 b/gcc/testsuite/gfortran.dg/bind-c-contiguous-1.f90 new file mode 100644 index 0000000..77dd3a2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind-c-contiguous-1.f90 @@ -0,0 +1,1574 @@ +! { dg-do run } +! { dg-additional-sources bind-c-contiguous-1.c } +! { dg-additional-options "-fcheck=all" } +! { dg-prune-output "command-line option '-fcheck=.*' is valid for Fortran but not for C" } + +! Fortran demands that with bind(C), the callee ensure that for +! * 'contiguous' +! * len=* with explicit/assumed-size arrays +! noncontiguous actual arguments are handled. +! (in without bind(C) in gfortran, caller handles the copy in/out + +! Additionally, for a bind(C) callee, a Fortran-written caller +! has to ensure the same (for contiguous + len=* to explicit-/assumed-size arrays) + +module m + use iso_c_binding, only: c_intptr_t, c_bool, c_loc, c_int + implicit none (type, external) + + type, bind(C) :: loc_t + integer(c_intptr_t) :: x, y, z + end type loc_t + +interface + type(loc_t) function char_assumed_size_c (xx, yy, zz, n, num) bind(C) + import :: loc_t, c_bool, c_int + integer(c_int), value :: n, num + character(len=*) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*) + end function + + type(loc_t) function char_assumed_size_in_c (xx, yy, zz, n, num) bind(C) + import :: loc_t, c_bool, c_int + integer(c_int), value :: n, num + character(len=*), intent(in) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*) + end function + + type(loc_t) function char_expl_size_c (xx, yy, zz, n, num) bind(c) + import :: loc_t, c_bool, c_int + integer(c_int), value :: n, num + character(len=*) :: xx(n), yy(n:n+3), zz(6:6, 3:n, 3:n+3) + end function + + type(loc_t) function char_expl_size_in_c (xx, yy, zz, n, num) bind(c) + import :: loc_t, c_bool, c_int + integer(c_int), value :: n, num + character(len=*), intent(in) :: xx(n), yy(n:n+3), zz(6:6, 3:n, 3:n+3) + end function + + type(loc_t) function char_assumed_rank_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*) :: xx(..) + character(len=3) :: yy(..) + character(len=k) :: zz(..) + end function + + type(loc_t) function char_assumed_rank_in_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), intent(in) :: xx(..) + character(len=3), intent(in) :: yy(..) + character(len=k), intent(in) :: zz(..) + end function + + type(loc_t) function char_assumed_rank_cont_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), contiguous :: xx(..) + character(len=3), contiguous :: yy(..) + character(len=k), contiguous :: zz(..) + end function + + type(loc_t) function char_assumed_rank_cont_in_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), contiguous, intent(in) :: xx(..) + character(len=3), contiguous, intent(in) :: yy(..) + character(len=k), contiguous, intent(in) :: zz(..) + end function + + type(loc_t) function char_assumed_shape_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*) :: xx(:) + character(len=3) :: yy(5:) + character(len=k) :: zz(-k:) + end function + + type(loc_t) function char_assumed_shape_in_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), intent(in) :: xx(:) + character(len=3), intent(in) :: yy(5:) + character(len=k), intent(in) :: zz(-k:) + end function + + type(loc_t) function char_assumed_shape_cont_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), contiguous :: xx(:) + character(len=3), contiguous :: yy(5:) + character(len=k), contiguous :: zz(-k:) + end function + + type(loc_t) function char_assumed_shape_cont_in_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), contiguous, intent(in) :: xx(:) + character(len=3), contiguous, intent(in) :: yy(5:) + character(len=k), contiguous, intent(in) :: zz(-k:) + end function +end interface + +contains + +type(loc_t) function char_assumed_size_f (xx, yy, zz, n, num) bind(c) result(res) + integer, value :: num, n + character(len=*) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*) + print *, xx(1:3) + if (3 /= len(xx)) error stop 1 + if (3 /= len(yy)) error stop 1 + if (3 /= len(zz)) error stop 1 + if (1 /= lbound(xx,dim=1)) error stop 1 + if (3 /= lbound(yy,dim=1)) error stop 1 + if (6 /= lbound(zz,dim=1)) error stop 1 + if (3 /= lbound(zz,dim=2)) error stop 1 + if (3 /= lbound(zz,dim=3)) error stop 1 + if (1 /= size(zz,dim=1)) error stop 1 + if (1 /= size(zz,dim=2)) error stop 1 + if (6 /= ubound(zz,dim=1)) error stop 1 + if (3 /= ubound(zz,dim=2)) error stop 1 + if (num == 1) then + if (xx(1) /= "abc") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "nop") error stop 4 + if (yy(3) /= "abc") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "nop") error stop 4 + if (zz(6,n,3) /= "abc") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "nop") error stop 4 + else if (num == 2) then + if (xx(1) /= "def") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "jlm") error stop 4 + if (yy(3) /= "def") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "jlm") error stop 4 + if (zz(6,n,3) /= "def") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "jlm") error stop 4 + else + error stop 8 + endif + xx(1) = "ABC" + xx(2) = "DEF" + xx(3) = "GHI" + yy(3) = "ABC" + yy(4) = "DEF" + yy(5) = "GHI" + zz(6,n,3) = "ABC" + zz(6,n,4) = "DEF" + zz(6,n,5) = "GHI" + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + +type(loc_t) function char_assumed_size_in_f (xx, yy, zz, n, num) bind(c) result(res) + integer, value :: num, n + character(len=*) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*) + intent(in) :: xx, yy, zz + print *, xx(1:3) + if (3 /= len(xx)) error stop 1 + if (3 /= len(yy)) error stop 1 + if (3 /= len(zz)) error stop 1 + if (1 /= lbound(xx,dim=1)) error stop 1 + if (3 /= lbound(yy,dim=1)) error stop 1 + if (6 /= lbound(zz,dim=1)) error stop 1 + if (3 /= lbound(zz,dim=2)) error stop 1 + if (3 /= lbound(zz,dim=3)) error stop 1 + if (1 /= size(zz,dim=1)) error stop 1 + if (1 /= size(zz,dim=2)) error stop 1 + if (6 /= ubound(zz,dim=1)) error stop 1 + if (3 /= ubound(zz,dim=2)) error stop 1 + if (num == 1) then + if (xx(1) /= "abc") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "nop") error stop 4 + if (yy(3) /= "abc") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "nop") error stop 4 + if (zz(6,n,3) /= "abc") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "nop") error stop 4 + else if (num == 2) then + if (xx(1) /= "def") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "jlm") error stop 4 + if (yy(3) /= "def") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "jlm") error stop 4 + if (zz(6,n,3) /= "def") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "jlm") error stop 4 + else + error stop 8 + endif + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } if (num == 1) then +end + +type(loc_t) function char_expl_size_f (xx, yy, zz, n, num) bind(c) result(res) + integer, value :: num, n + character(len=*) :: xx(n), yy(n:n+2), zz(6:6, 3:n, 3:n+2) + print *, xx(1:3) + if (3 /= len(xx)) error stop 1 + if (3 /= len(yy)) error stop 1 + if (3 /= len(zz)) error stop 1 + if (1 /= lbound(xx,dim=1)) error stop 1 + if (3 /= lbound(yy,dim=1)) error stop 1 + if (6 /= lbound(zz,dim=1)) error stop 1 + if (3 /= lbound(zz,dim=2)) error stop 1 + if (3 /= lbound(zz,dim=3)) error stop 1 + if (3 /= size(xx,dim=1)) error stop 1 + if (3 /= size(yy,dim=1)) error stop 1 + if (1 /= size(zz,dim=1)) error stop 1 + if (1 /= size(zz,dim=2)) error stop 1 + if (3 /= size(zz,dim=3)) error stop 1 + if (3 /= ubound(xx,dim=1)) error stop 1 + if (5 /= ubound(yy,dim=1)) error stop 1 + if (6 /= ubound(zz,dim=1)) error stop 1 + if (3 /= ubound(zz,dim=2)) error stop 1 + if (5 /= ubound(zz,dim=3)) error stop 1 + if (num == 1) then + if (xx(1) /= "abc") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "nop") error stop 4 + if (yy(3) /= "abc") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "nop") error stop 4 + if (zz(6,n,3) /= "abc") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "nop") error stop 4 + else if (num == 2) then + if (xx(1) /= "def") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "jlm") error stop 4 + if (yy(3) /= "def") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "jlm") error stop 4 + if (zz(6,n,3) /= "def") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "jlm") error stop 4 + else + error stop 8 + endif + xx(1) = "ABC" + xx(2) = "DEF" + xx(3) = "GHI" + yy(3) = "ABC" + yy(4) = "DEF" + yy(5) = "GHI" + zz(6,n,3) = "ABC" + zz(6,n,4) = "DEF" + zz(6,n,5) = "GHI" + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + +type(loc_t) function char_expl_size_in_f (xx, yy, zz, n, num) bind(c) result(res) + integer, value :: num, n + character(len=*) :: xx(n), yy(n:n+2), zz(6:6, 3:n, 3:n+2) + intent(in) :: xx, yy, zz + print *, xx(1:3) + if (3 /= len(xx)) error stop 1 + if (3 /= len(yy)) error stop 1 + if (3 /= len(zz)) error stop 1 + if (1 /= lbound(xx,dim=1)) error stop 1 + if (3 /= lbound(yy,dim=1)) error stop 1 + if (6 /= lbound(zz,dim=1)) error stop 1 + if (3 /= lbound(zz,dim=2)) error stop 1 + if (3 /= lbound(zz,dim=3)) error stop 1 + if (3 /= size(xx,dim=1)) error stop 1 + if (3 /= size(yy,dim=1)) error stop 1 + if (1 /= size(zz,dim=1)) error stop 1 + if (1 /= size(zz,dim=2)) error stop 1 + if (3 /= size(zz,dim=3)) error stop 1 + if (3 /= ubound(xx,dim=1)) error stop 1 + if (5 /= ubound(yy,dim=1)) error stop 1 + if (6 /= ubound(zz,dim=1)) error stop 1 + if (3 /= ubound(zz,dim=2)) error stop 1 + if (5 /= ubound(zz,dim=3)) error stop 1 + if (num == 1) then + if (xx(1) /= "abc") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "nop") error stop 4 + if (yy(3) /= "abc") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "nop") error stop 4 + if (zz(6,n,3) /= "abc") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "nop") error stop 4 + else if (num == 2) then + if (xx(1) /= "def") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "jlm") error stop 4 + if (yy(3) /= "def") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "jlm") error stop 4 + if (zz(6,n,3) /= "def") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "jlm") error stop 4 + else + error stop 8 + endif + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + + +type(loc_t) function char_assumed_rank_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*) :: xx(..) + character(len=3) :: yy(..) + character(len=k) :: zz(..) + if (3 /= len(xx)) error stop 40 + if (3 /= len(yy)) error stop 40 + if (3 /= len(zz)) error stop 40 + if (3 /= size(xx)) error stop 41 + if (3 /= size(yy)) error stop 41 + if (3 /= size(zz)) error stop 41 + if (1 /= rank(xx)) error stop 49 + if (1 /= rank(yy)) error stop 49 + if (1 /= rank(zz)) error stop 49 + if (1 /= lbound(xx, dim=1)) stop 49 + if (1 /= lbound(yy, dim=1)) stop 49 + if (1 /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (3 /= ubound(yy, dim=1)) stop 49 + if (3 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (is_contiguous (xx)) error stop 49 + if (is_contiguous (yy)) error stop 49 + if (is_contiguous (zz)) error stop 49 + else if (num == 2) then + if (.not. is_contiguous (xx)) error stop 49 + if (.not. is_contiguous (yy)) error stop 49 + if (.not. is_contiguous (zz)) error stop 49 + else + error stop 48 + end if + select rank (xx) + rank (1) + print *, xx(1:3) + if (num == 1) then + if (xx(1) /= "abc") error stop 42 + if (xx(2) /= "ghi") error stop 43 + if (xx(3) /= "nop") error stop 44 + else if (num == 2) then + if (xx(1) /= "def") error stop 45 + if (xx(2) /= "ghi") error stop 46 + if (xx(3) /= "jlm") error stop 47 + else + error stop 48 + endif + xx(1) = "ABC" + xx(2) = "DEF" + xx(3) = "GHI" + res%x = get_loc (xx) + rank default + error stop 99 + end select + select rank (yy) + rank (1) + print *, yy(1:3) + if (num == 1) then + if (yy(1) /= "abc") error stop 42 + if (yy(2) /= "ghi") error stop 43 + if (yy(3) /= "nop") error stop 44 + else if (num == 2) then + if (yy(1) /= "def") error stop 45 + if (yy(2) /= "ghi") error stop 46 + if (yy(3) /= "jlm") error stop 47 + else + error stop 48 + endif + yy(1) = "ABC" + yy(2) = "DEF" + yy(3) = "GHI" + res%y = get_loc (yy) + rank default + error stop 99 + end select + select rank (zz) + rank (1) + print *, zz(1:3) + if (num == 1) then + if (zz(1) /= "abc") error stop 42 + if (zz(2) /= "ghi") error stop 43 + if (zz(3) /= "nop") error stop 44 + else if (num == 2) then + if (zz(1) /= "def") error stop 45 + if (zz(2) /= "ghi") error stop 46 + if (zz(3) /= "jlm") error stop 47 + else + error stop 48 + endif + zz(1) = "ABC" + zz(2) = "DEF" + zz(3) = "GHI" + res%z = get_loc (zz) + rank default + error stop 99 + end select +contains + integer (c_intptr_t) function get_loc (arg) + character(len=*), target :: arg(:) + ! %loc does copy in/out if not simply contiguous + ! extra func needed because of 'target' attribute + get_loc = transfer (c_loc(arg), res%x) + end +end + +type(loc_t) function char_assumed_rank_in_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*) :: xx(..) + character(len=3) :: yy(..) + character(len=k) :: zz(..) + intent(in) :: xx, yy, zz + if (3 /= size(yy)) error stop 50 + if (3 /= len(yy)) error stop 51 + if (1 /= rank(yy)) error stop 59 + if (1 /= lbound(xx, dim=1)) stop 49 + if (1 /= lbound(yy, dim=1)) stop 49 + if (1 /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (3 /= ubound(yy, dim=1)) stop 49 + if (3 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (is_contiguous (xx)) error stop 59 + if (is_contiguous (yy)) error stop 59 + if (is_contiguous (zz)) error stop 59 + else if (num == 2) then + if (.not. is_contiguous (xx)) error stop 59 + if (.not. is_contiguous (yy)) error stop 59 + if (.not. is_contiguous (zz)) error stop 59 + else + error stop 48 + end if + select rank (xx) + rank (1) + print *, xx(1:3) + if (num == 1) then + if (xx(1) /= "abc") error stop 52 + if (xx(2) /= "ghi") error stop 53 + if (xx(3) /= "nop") error stop 54 + else if (num == 2) then + if (xx(1) /= "def") error stop 55 + if (xx(2) /= "ghi") error stop 56 + if (xx(3) /= "jlm") error stop 57 + else + error stop 58 + endif + res%x = get_loc(xx) + rank default + error stop 99 + end select + select rank (yy) + rank (1) + print *, yy(1:3) + if (num == 1) then + if (yy(1) /= "abc") error stop 52 + if (yy(2) /= "ghi") error stop 53 + if (yy(3) /= "nop") error stop 54 + else if (num == 2) then + if (yy(1) /= "def") error stop 55 + if (yy(2) /= "ghi") error stop 56 + if (yy(3) /= "jlm") error stop 57 + else + error stop 58 + endif + res%y = get_loc(yy) + rank default + error stop 99 + end select + select rank (zz) + rank (1) + print *, zz(1:3) + if (num == 1) then + if (zz(1) /= "abc") error stop 52 + if (zz(2) /= "ghi") error stop 53 + if (zz(3) /= "nop") error stop 54 + else if (num == 2) then + if (zz(1) /= "def") error stop 55 + if (zz(2) /= "ghi") error stop 56 + if (zz(3) /= "jlm") error stop 57 + else + error stop 58 + endif + res%z = get_loc(zz) + rank default + error stop 99 + end select +contains + integer (c_intptr_t) function get_loc (arg) + character(len=*), target :: arg(:) + ! %loc does copy in/out if not simply contiguous + ! extra func needed because of 'target' attribute + get_loc = transfer (c_loc(arg), res%x) + end +end + + + +type(loc_t) function char_assumed_rank_cont_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*) :: xx(..) + character(len=3) :: yy(..) + character(len=k) :: zz(..) + contiguous :: xx, yy, zz + if (3 /= len(xx)) error stop 60 + if (3 /= len(yy)) error stop 60 + if (3 /= len(zz)) error stop 60 + if (3 /= size(xx)) error stop 61 + if (3 /= size(yy)) error stop 61 + if (3 /= size(zz)) error stop 61 + if (1 /= rank(xx)) error stop 69 + if (1 /= rank(yy)) error stop 69 + if (1 /= rank(zz)) error stop 69 + if (1 /= lbound(xx, dim=1)) stop 49 + if (1 /= lbound(yy, dim=1)) stop 49 + if (1 /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (3 /= ubound(yy, dim=1)) stop 49 + if (3 /= ubound(zz, dim=1)) stop 49 + select rank (xx) + rank (1) + print *, xx(1:3) + if (num == 1) then + if (xx(1) /= "abc") error stop 62 + if (xx(2) /= "ghi") error stop 63 + if (xx(3) /= "nop") error stop 64 + else if (num == 2) then + if (xx(1) /= "def") error stop 65 + if (xx(2) /= "ghi") error stop 66 + if (xx(3) /= "jlm") error stop 67 + else + error stop 68 + endif + xx(1) = "ABC" + xx(2) = "DEF" + xx(3) = "GHI" + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select + select rank (yy) + rank (1) + print *, yy(1:3) + if (num == 1) then + if (yy(1) /= "abc") error stop 62 + if (yy(2) /= "ghi") error stop 63 + if (yy(3) /= "nop") error stop 64 + else if (num == 2) then + if (yy(1) /= "def") error stop 65 + if (yy(2) /= "ghi") error stop 66 + if (yy(3) /= "jlm") error stop 67 + else + error stop 68 + endif + yy(1) = "ABC" + yy(2) = "DEF" + yy(3) = "GHI" + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select + select rank (zz) + rank (1) + print *, zz(1:3) + if (num == 1) then + if (zz(1) /= "abc") error stop 62 + if (zz(2) /= "ghi") error stop 63 + if (zz(3) /= "nop") error stop 64 + else if (num == 2) then + if (zz(1) /= "def") error stop 65 + if (zz(2) /= "ghi") error stop 66 + if (zz(3) /= "jlm") error stop 67 + else + error stop 68 + endif + zz(1) = "ABC" + zz(2) = "DEF" + zz(3) = "GHI" + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select +end + +type(loc_t) function char_assumed_rank_cont_in_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*) :: xx(..) + character(len=3) :: yy(..) + character(len=k) :: zz(..) + intent(in) :: xx, yy, zz + contiguous :: xx, yy, zz + if (3 /= size(xx)) error stop 30 + if (3 /= size(yy)) error stop 30 + if (3 /= size(zz)) error stop 30 + if (3 /= len(xx)) error stop 31 + if (3 /= len(yy)) error stop 31 + if (3 /= len(zz)) error stop 31 + if (1 /= rank(xx)) error stop 69 + if (1 /= rank(yy)) error stop 69 + if (1 /= rank(zz)) error stop 69 + if (1 /= lbound(xx, dim=1)) stop 49 + if (1 /= lbound(yy, dim=1)) stop 49 + if (1 /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (3 /= ubound(yy, dim=1)) stop 49 + if (3 /= ubound(zz, dim=1)) stop 49 + select rank (xx) + rank (1) + print *, xx(1:3) + if (num == 1) then + if (xx(1) /= "abc") error stop 62 + if (xx(2) /= "ghi") error stop 63 + if (xx(3) /= "nop") error stop 64 + else if (num == 2) then + if (xx(1) /= "def") error stop 65 + if (xx(2) /= "ghi") error stop 66 + if (xx(3) /= "jlm") error stop 67 + else + error stop 68 + endif + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select + select rank (yy) + rank (1) + print *, yy(1:3) + if (num == 1) then + if (yy(1) /= "abc") error stop 62 + if (yy(2) /= "ghi") error stop 63 + if (yy(3) /= "nop") error stop 64 + else if (num == 2) then + if (yy(1) /= "def") error stop 65 + if (yy(2) /= "ghi") error stop 66 + if (yy(3) /= "jlm") error stop 67 + else + error stop 68 + endif + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select + select rank (zz) + rank (1) + print *, zz(1:3) + if (num == 1) then + if (zz(1) /= "abc") error stop 62 + if (zz(2) /= "ghi") error stop 63 + if (zz(3) /= "nop") error stop 64 + else if (num == 2) then + if (zz(1) /= "def") error stop 65 + if (zz(2) /= "ghi") error stop 66 + if (zz(3) /= "jlm") error stop 67 + else + error stop 68 + endif + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select +end + +type(loc_t) function char_assumed_shape_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*) :: xx(:) + character(len=3) :: yy(5:) + character(len=k) :: zz(-k:) + print *, xx(1:3) + if (3 /= len(xx)) error stop 70 + if (3 /= len(yy)) error stop 70 + if (3 /= len(zz)) error stop 70 + if (3 /= size(xx)) error stop 71 + if (3 /= size(yy)) error stop 71 + if (3 /= size(zz)) error stop 71 + if (1 /= lbound(xx, dim=1)) stop 49 + if (5 /= lbound(yy, dim=1)) stop 49 + if (-k /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (7 /= ubound(yy, dim=1)) stop 49 + if (-k+2 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (is_contiguous (xx)) error stop 79 + if (is_contiguous (yy)) error stop 79 + if (is_contiguous (zz)) error stop 79 + if (xx(1) /= "abc") error stop 72 + if (xx(2) /= "ghi") error stop 73 + if (xx(3) /= "nop") error stop 74 + if (yy(5) /= "abc") error stop 72 + if (yy(6) /= "ghi") error stop 73 + if (yy(7) /= "nop") error stop 74 + if (zz(-k) /= "abc") error stop 72 + if (zz(-k+1) /= "ghi") error stop 73 + if (zz(-k+2) /= "nop") error stop 74 + else if (num == 2) then + if (.not.is_contiguous (xx)) error stop 79 + if (.not.is_contiguous (yy)) error stop 79 + if (.not.is_contiguous (zz)) error stop 79 + if (xx(1) /= "def") error stop 72 + if (xx(2) /= "ghi") error stop 73 + if (xx(3) /= "jlm") error stop 74 + if (yy(5) /= "def") error stop 72 + if (yy(6) /= "ghi") error stop 73 + if (yy(7) /= "jlm") error stop 74 + if (zz(-k) /= "def") error stop 72 + if (zz(-k+1) /= "ghi") error stop 73 + if (zz(-k+2) /= "jlm") error stop 74 + else + error stop 78 + endif + xx(1) = "ABC" + xx(2) = "DEF" + xx(3) = "GHI" + yy(5) = "ABC" + yy(6) = "DEF" + yy(7) = "GHI" + zz(-k) = "ABC" + zz(-k+1) = "DEF" + zz(-k+2) = "GHI" + res%x = get_loc(xx) + res%y = get_loc(yy) + res%z = get_loc(zz) +contains + integer (c_intptr_t) function get_loc (arg) + character(len=*), target :: arg(:) + ! %loc does copy in/out if not simply contiguous + ! extra func needed because of 'target' attribute + get_loc = transfer (c_loc(arg), res%x) + end +end + +type(loc_t) function char_assumed_shape_in_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*) :: xx(:) + character(len=3) :: yy(5:) + character(len=k) :: zz(-k:) + intent(in) :: xx, yy, zz + print *, xx(1:3) + if (3 /= size(xx)) error stop 80 + if (3 /= size(yy)) error stop 80 + if (3 /= size(zz)) error stop 80 + if (3 /= len(xx)) error stop 81 + if (3 /= len(yy)) error stop 81 + if (3 /= len(zz)) error stop 81 + if (1 /= lbound(xx, dim=1)) stop 49 + if (5 /= lbound(yy, dim=1)) stop 49 + if (-k /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (7 /= ubound(yy, dim=1)) stop 49 + if (-k+2 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (is_contiguous (xx)) error stop 89 + if (is_contiguous (yy)) error stop 89 + if (is_contiguous (zz)) error stop 89 + if (xx(1) /= "abc") error stop 82 + if (xx(2) /= "ghi") error stop 83 + if (xx(3) /= "nop") error stop 84 + if (yy(5) /= "abc") error stop 82 + if (yy(6) /= "ghi") error stop 83 + if (yy(7) /= "nop") error stop 84 + if (zz(-k) /= "abc") error stop 82 + if (zz(-k+1) /= "ghi") error stop 83 + if (zz(-k+2) /= "nop") error stop 84 + else if (num == 2) then + if (.not.is_contiguous (xx)) error stop 89 + if (.not.is_contiguous (yy)) error stop 89 + if (.not.is_contiguous (zz)) error stop 89 + if (xx(1) /= "def") error stop 85 + if (xx(2) /= "ghi") error stop 86 + if (xx(3) /= "jlm") error stop 87 + if (yy(5) /= "def") error stop 85 + if (yy(6) /= "ghi") error stop 86 + if (yy(7) /= "jlm") error stop 87 + if (zz(-k) /= "def") error stop 85 + if (zz(-k+1) /= "ghi") error stop 86 + if (zz(-k+2) /= "jlm") error stop 87 + else + error stop 88 + endif + res%x = get_loc(xx) + res%y = get_loc(yy) + res%z = get_loc(zz) +contains + integer (c_intptr_t) function get_loc (arg) + character(len=*), target :: arg(:) + ! %loc does copy in/out if not simply contiguous + ! extra func needed because of 'target' attribute + get_loc = transfer (c_loc(arg), res%x) + end +end + + + +type(loc_t) function char_assumed_shape_cont_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*) :: xx(:) + character(len=3) :: yy(5:) + character(len=k) :: zz(-k:) + contiguous :: xx, yy, zz + print *, xx(1:3) + if (3 /= len(xx)) error stop 90 + if (3 /= len(yy)) error stop 90 + if (3 /= len(zz)) error stop 90 + if (3 /= size(xx)) error stop 91 + if (3 /= size(yy)) error stop 91 + if (3 /= size(zz)) error stop 91 + if (1 /= lbound(xx, dim=1)) stop 49 + if (5 /= lbound(yy, dim=1)) stop 49 + if (-k /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (7 /= ubound(yy, dim=1)) stop 49 + if (-k+2 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (xx(1) /= "abc") error stop 92 + if (xx(2) /= "ghi") error stop 93 + if (xx(3) /= "nop") error stop 94 + if (yy(5) /= "abc") error stop 92 + if (yy(6) /= "ghi") error stop 93 + if (yy(7) /= "nop") error stop 94 + if (zz(-k) /= "abc") error stop 92 + if (zz(-k+1) /= "ghi") error stop 93 + if (zz(-k+2) /= "nop") error stop 94 + else if (num == 2) then + if (xx(1) /= "def") error stop 92 + if (xx(2) /= "ghi") error stop 93 + if (xx(3) /= "jlm") error stop 94 + if (yy(5) /= "def") error stop 92 + if (yy(6) /= "ghi") error stop 93 + if (yy(7) /= "jlm") error stop 94 + if (zz(-k) /= "def") error stop 92 + if (zz(-k+1) /= "ghi") error stop 93 + if (zz(-k+2) /= "jlm") error stop 94 + else + error stop 98 + endif + xx(1) = "ABC" + xx(2) = "DEF" + xx(3) = "GHI" + yy(5) = "ABC" + yy(6) = "DEF" + yy(7) = "GHI" + zz(-k) = "ABC" + zz(-k+1) = "DEF" + zz(-k+2) = "GHI" + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + +type(loc_t) function char_assumed_shape_cont_in_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*) :: xx(:) + character(len=3) :: yy(5:) + character(len=k) :: zz(-k:) + intent(in) :: xx, yy, zz + contiguous :: xx, yy, zz + print *, xx(1:3) + if (3 /= size(xx)) error stop 100 + if (3 /= size(yy)) error stop 100 + if (3 /= size(zz)) error stop 100 + if (3 /= len(xx)) error stop 101 + if (3 /= len(yy)) error stop 101 + if (3 /= len(zz)) error stop 101 + if (1 /= lbound(xx, dim=1)) stop 49 + if (5 /= lbound(yy, dim=1)) stop 49 + if (-k /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (7 /= ubound(yy, dim=1)) stop 49 + if (-k+2 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (xx(1) /= "abc") error stop 102 + if (xx(2) /= "ghi") error stop 103 + if (xx(3) /= "nop") error stop 104 + if (yy(5) /= "abc") error stop 102 + if (yy(6) /= "ghi") error stop 103 + if (yy(7) /= "nop") error stop 104 + if (zz(-k) /= "abc") error stop 102 + if (zz(-k+1) /= "ghi") error stop 103 + if (zz(-k+2) /= "nop") error stop 104 + else if (num == 2) then + if (xx(1) /= "def") error stop 105 + if (xx(2) /= "ghi") error stop 106 + if (xx(3) /= "jlm") error stop 107 + if (yy(5) /= "def") error stop 105 + if (yy(6) /= "ghi") error stop 106 + if (yy(7) /= "jlm") error stop 107 + if (zz(-k) /= "def") error stop 105 + if (zz(-k+1) /= "ghi") error stop 106 + if (zz(-k+2) /= "jlm") error stop 107 + else + error stop 108 + endif + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + +end module + + +use m +implicit none (type, external) +character(len=3) :: a(6), a2(6), a3(6), a_init(6) +type(loc_t) :: loc3 + +a_init = ['abc', 'def', 'ghi', 'jlm', 'nop', 'qrs'] + +! -- Fortran: assumed size +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_f (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_in_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_in_f (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- Fortran: explicit shape +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_f (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_in_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_in_f (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- Fortran: assumed rank +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_f (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- Fortran: assumed rank contiguous +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- Fortran: assumed shape +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_f (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- Fortran: assumed shape contiguous +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + + +! --- character - call C directly -- + +! -- C: assumed size +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_c (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_in_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_in_c (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- C: explicit shape +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_c (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_in_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_in_c (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- C: assumed rank +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_c (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- C: assumed rank contiguous +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- C: assumed shape +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_c (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- C: assumed shape contiguous +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 +end + + +! { dg-output "At line 928 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_f'(\n|\r\n|\r)" }" +! { dg-output "At line 928 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_f'(\n|\r\n|\r)" }" +! { dg-output "At line 928 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_f'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 946 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_in_f'(\n|\r\n|\r)" }" +! { dg-output "At line 946 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_in_f'(\n|\r\n|\r)" }" +! { dg-output "At line 946 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_in_f'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 965 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_f'(\n|\r\n|\r)" }" +! { dg-output "At line 965 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_f'(\n|\r\n|\r)" }" +! { dg-output "At line 965 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_f'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 983 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_in_f'(\n|\r\n|\r)" }" +! { dg-output "At line 983 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_in_f'(\n|\r\n|\r)" }" +! { dg-output "At line 983 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_in_f'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1039 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1039 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1039 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_f'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1057 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_in_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1057 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_in_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1057 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_in_f'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1113 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1113 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1113 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_f'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1131 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_in_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1131 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_in_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1131 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_in_f'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1153 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1153 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1153 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_c'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1171 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_in_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1171 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_in_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1171 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_in_c'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1190 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1190 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1190 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_c'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1208 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_in_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1208 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_in_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1208 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_in_c'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1264 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1264 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1264 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_c'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1282 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_in_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1282 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_in_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1282 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_in_c'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1338 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1338 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1338 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_c'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1356 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_in_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1356 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_in_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1356 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_in_c'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" diff --git a/gcc/testsuite/gfortran.dg/bind-c-contiguous-2.f90 b/gcc/testsuite/gfortran.dg/bind-c-contiguous-2.f90 new file mode 100644 index 0000000..5b54680 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind-c-contiguous-2.f90 @@ -0,0 +1,82 @@ +! { dg-additional-options "-fdump-tree-original" } + +integer function f(xx) bind(c) result(ii) + implicit none + integer, contiguous :: xx(..) + ii = rank(xx) +end + +integer function h(yy) bind(c) result(jj) + implicit none + character(len=*), contiguous :: yy(:) + jj = rank(yy) +end + +integer function g(zz) bind(c) result(kk) + implicit none + character(len=*) :: zz(*) + kk = rank(zz) +end + + + +integer function f2(aa) bind(c) result(ii) + implicit none + integer, contiguous :: aa(..) + intent(in) :: aa + ii = rank(aa) +end + +integer function h2(bb) bind(c) result(jj) + implicit none + character(len=*), contiguous :: bb(:) + intent(in) :: bb + jj = rank(bb) +end + +integer function g2(cc) bind(c) result(kk) + implicit none + character(len=*) :: cc(*) + intent(in) :: cc + kk = rank(cc) +end + +! +! Copy-in/out variable: +! +! { dg-final { scan-tree-dump-times "xx->data =\[^;\]+ __builtin_malloc \\(_xx->elem_len \\* size.\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "yy->data =\[^;\]+ __builtin_malloc \\(_yy->elem_len \\* size.\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "zz =\[^;\]+ __builtin_malloc \\(_zz->elem_len \\* size.\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "aa->data =\[^;\]+ __builtin_malloc \\(_aa->elem_len \\* size.\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "bb->data =\[^;\]+ __builtin_malloc \\(_bb->elem_len \\* size.\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "cc =\[^;\]+ __builtin_malloc \\(_cc->elem_len \\* size.\[0-9\]+\\);" 1 "original" } } + +! { dg-final { scan-tree-dump-times "__builtin_free \\(\[^;\]+ xx->data\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free \\(\[^;\]+ yy->data\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free \\(zz\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free \\(\[^;\]+ aa->data\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free \\(\[^;\]+ bb->data\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free \\(cc\\);" 1 "original" } } + +! Copy in + out + +! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) xx->data \\+ xx->dtype.elem_len \\* arrayidx.\[0-9\]+, _xx->base_addr \\+ shift.\[0-9\]+, xx->dtype.elem_len\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "xx->data = \\(void \\* restrict\\) _xx->base_addr;" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) xx->data \\+ xx->dtype.elem_len \\* arrayidx.\[0-9\]+, _xx->base_addr \\+ shift.\[0-9\]+, xx->dtype.elem_len\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) yy->data \\+ yy->dtype.elem_len \\* arrayidx.\[0-9\]+, _yy->base_addr \\+ shift.\[0-9\]+, yy->dtype.elem_len\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "yy->data = \\(void \\* restrict\\) _yy->base_addr;" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(_yy->base_addr \\+ shift.\[0-9\]+, \\(void \\*\\) yy->data \\+ yy->dtype.elem_len \\* arrayidx.\[0-9\]+, yy->dtype.elem_len\\);" 1 "original" } } + +! { dg-final { scan-tree-dump-times "zz = \\(character\\(kind=1\\)\\\[0:\\\]\\\[1:zz.\[0-9\]+\\\] \\* restrict\\) _zz->base_addr;" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) zz \\+ _zz->elem_len \\* arrayidx.\[0-9\]+, _zz->base_addr \\+ shift.\[0-9\]+, _zz->elem_len\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(_zz->base_addr \\+ shift.\[0-9\]+, \\(void \\*\\) zz \\+ _zz->elem_len \\* arrayidx.\[0-9\]+, _zz->elem_len\\);" 1 "original" } } + +! Copy in only + +! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) aa->data \\+ aa->dtype.elem_len \\* arrayidx.\[0-9\]+, _aa->base_addr \\+ shift.\[0-9\]+, aa->dtype.elem_len\\);" 1 "original" } } + +! { dg-final { scan-tree-dump-times "aa->data = \\(void \\* restrict\\) _aa->base_addr;" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) bb->data \\+ bb->dtype.elem_len \\* arrayidx.\[0-9\]+, _bb->base_addr \\+ shift.\[0-9\]+, bb->dtype.elem_len\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "bb->data = \\(void \\* restrict\\) _bb->base_addr;" 1 "original" } } +! { dg-final { scan-tree-dump-times "cc = \\(character\\(kind=1\\)\\\[0:\\\]\\\[1:cc.\[0-9\]+\\\] \\* restrict\\) _cc->base_addr;" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) cc \\+ _cc->elem_len \\* arrayidx.\[0-9\]+, _cc->base_addr \\+ shift.\[0-9\]+, _cc->elem_len\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/bind-c-contiguous-3.c b/gcc/testsuite/gfortran.dg/bind-c-contiguous-3.c new file mode 100644 index 0000000..506f753 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind-c-contiguous-3.c @@ -0,0 +1,180 @@ +#include <ISO_Fortran_binding.h> + +intptr_t assumed_rank_alloc_f (CFI_cdesc_t *); +intptr_t assumed_rank_pointer_f (CFI_cdesc_t *); +intptr_t assumed_rank_f (CFI_cdesc_t *); +intptr_t assumed_rank_cont_f (CFI_cdesc_t *); +intptr_t assumed_shape_f (CFI_cdesc_t *); +intptr_t assumed_shape_cont_f (CFI_cdesc_t *); +intptr_t deferred_shape_alloc_f (CFI_cdesc_t *); +intptr_t deferred_shape_pointer_f (CFI_cdesc_t *); + + +static void +basic_check(CFI_cdesc_t *x) +{ + if (!x->base_addr) + __builtin_abort (); + if (x->elem_len != sizeof(int32_t)) + __builtin_abort (); + if (x->version != CFI_VERSION) + __builtin_abort (); + if (x->rank != 4) + __builtin_abort (); + if (x->type != CFI_type_int32_t) + __builtin_abort (); + if (x->attribute == CFI_attribute_other) + { + if (x->dim[0].lower_bound != 0) + __builtin_abort (); + if (x->dim[1].lower_bound != 0) + __builtin_abort (); + if (x->dim[2].lower_bound != 0) + __builtin_abort (); + if (x->dim[3].lower_bound != 0) + __builtin_abort (); + } +} + +intptr_t +assumed_rank_alloc_c (CFI_cdesc_t *x) +{ + basic_check (x); + if (!CFI_is_contiguous (x)) + __builtin_abort (); + if (x->attribute != CFI_attribute_allocatable) + __builtin_abort (); + intptr_t addr = (intptr_t) x->base_addr; + intptr_t addr2 = assumed_rank_alloc_f (x); + if (addr != addr2 || addr != (intptr_t) x->base_addr) + __builtin_abort (); + return addr; +} + +intptr_t +assumed_rank_pointer_c (CFI_cdesc_t *x) +{ + basic_check (x); + if (x->attribute != CFI_attribute_pointer) + __builtin_abort (); + intptr_t addr = (intptr_t) x->base_addr; + intptr_t addr2 = assumed_rank_pointer_f (x); + if (addr != addr2 || addr != (intptr_t) x->base_addr) + __builtin_abort (); + return addr; +} + + +intptr_t +assumed_rank_c (CFI_cdesc_t *x) +{ + basic_check (x); + if (x->attribute != CFI_attribute_other) + __builtin_abort (); + intptr_t addr = (intptr_t) x->base_addr; + intptr_t addr2 = assumed_rank_f (x); + if (addr != addr2 || addr != (intptr_t) x->base_addr) + __builtin_abort (); + return addr; +} + +intptr_t +assumed_rank_cont_c (CFI_cdesc_t *x) +{ + basic_check (x); + if (!CFI_is_contiguous (x)) + __builtin_abort (); + if (x->attribute != CFI_attribute_other) + __builtin_abort (); + intptr_t addr = (intptr_t) x->base_addr; + intptr_t addr2 = assumed_rank_cont_f (x); + if (addr != addr2 || addr != (intptr_t) x->base_addr) + __builtin_abort (); + return addr; +} + +intptr_t +assumed_shape_c (CFI_cdesc_t *x, int num) +{ + basic_check (x); + if (x->attribute != CFI_attribute_other) + __builtin_abort (); + intptr_t addr = (intptr_t) x->base_addr; + intptr_t addr2; + if (num == 1 || num == 2 || num == 3) + { + if (!CFI_is_contiguous (x)) + __builtin_abort (); + } + else + { + if (CFI_is_contiguous (x)) + __builtin_abort (); + } + + if (num == 1 || num == 4) + addr2 = assumed_shape_f (x); + else if (num == 2 || num == 5) + addr2 = assumed_shape_cont_f (x); + else if (num == 3 || num == 6) + addr2 = assumed_rank_cont_f (x); + else + __builtin_abort (); + + if (num == 1 || num == 2 || num == 3) + { + if (addr != addr2) + __builtin_abort (); + } + else + { + if (CFI_is_contiguous (x)) + __builtin_abort (); + } + if (addr != (intptr_t) x->base_addr) + __builtin_abort (); + return addr2; +} + +intptr_t +assumed_shape_cont_c (CFI_cdesc_t *x) +{ + basic_check (x); + if (!CFI_is_contiguous (x)) + __builtin_abort (); + if (x->attribute != CFI_attribute_other) + __builtin_abort (); + intptr_t addr = (intptr_t) x->base_addr; + intptr_t addr2 = assumed_shape_cont_f (x); + if (addr != addr2 || addr != (intptr_t) x->base_addr) + __builtin_abort (); + return addr; +} + +intptr_t +deferred_shape_alloc_c (CFI_cdesc_t *x) +{ + basic_check (x); + if (!CFI_is_contiguous (x)) + __builtin_abort (); + if (x->attribute != CFI_attribute_allocatable) + __builtin_abort (); + intptr_t addr = (intptr_t) x->base_addr; + intptr_t addr2 = deferred_shape_alloc_f (x); + if (addr != addr2 || addr != (intptr_t) x->base_addr) + __builtin_abort (); + return addr; +} + +intptr_t +deferred_shape_pointer_c (CFI_cdesc_t *x) +{ + basic_check (x); + if (x->attribute != CFI_attribute_pointer) + __builtin_abort (); + intptr_t addr = (intptr_t) x->base_addr; + intptr_t addr2 = deferred_shape_pointer_f (x); + if (addr != addr2 || addr != (intptr_t) x->base_addr) + __builtin_abort (); + return addr; +} diff --git a/gcc/testsuite/gfortran.dg/bind-c-contiguous-3.f90 b/gcc/testsuite/gfortran.dg/bind-c-contiguous-3.f90 new file mode 100644 index 0000000..6e479ff --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind-c-contiguous-3.f90 @@ -0,0 +1,656 @@ +! { dg-do run } +! { dg-additional-sources bind-c-contiguous-3.c } + +! Test that multi-dim contiguous is properly handled. + +module m + use iso_c_binding, only: c_intptr_t, c_int + implicit none (type, external) + +interface + integer(c_intptr_t) function assumed_rank_alloc_c (xx) bind(c) + import :: c_intptr_t + integer, allocatable :: xx(..) + end function + integer(c_intptr_t) function assumed_rank_pointer_c (xx) bind(c) + import :: c_intptr_t + integer, pointer :: xx(..) + end function + integer(c_intptr_t) function assumed_rank_c (xx) bind(c) + import :: c_intptr_t + integer :: xx(..) + end function + integer(c_intptr_t) function assumed_rank_cont_c (xx) bind(c) + import :: c_intptr_t + integer, contiguous :: xx(..) + end function + integer(c_intptr_t) function assumed_shape_c (xx, num) bind(c) + import :: c_intptr_t, c_int + integer :: xx(:,:,:,:) + integer(c_int), value :: num + end function + integer(c_intptr_t) function assumed_shape_cont_c (xx) bind(c) + import :: c_intptr_t + integer, contiguous :: xx(:,:,:,:) + end function + integer(c_intptr_t) function deferred_shape_alloc_c (xx) bind(c) + import :: c_intptr_t + integer, allocatable :: xx(:,:,:,:) + end function + integer(c_intptr_t) function deferred_shape_pointer_c (xx) bind(c) + import :: c_intptr_t + integer, pointer :: xx(:,:,:,:) + end function + +end interface + +contains + +integer function get_n (idx, lbound, extent) result(res) + integer, contiguous :: idx(:), lbound(:), extent(:) + integer :: i + if (size(idx) /= size(lbound) .or. size(idx) /= size(extent)) & + error stop 20 + res = idx(1) - lbound(1) + 1 + do i = 2, size(idx) + res = res + product(extent(:i-1)) * (idx(i)-lbound(i)) + end do +end + +integer(c_intptr_t) function assumed_rank_alloc_f (xx) bind(c) result(res) + integer, allocatable :: xx(..) + integer :: i, j, k, l, lb(4) + select rank (xx) + rank (4) + do l = lbound(xx, dim=4), ubound(xx, dim=4) + do k = lbound(xx, dim=3), ubound(xx, dim=3) + do j = lbound(xx, dim=2), ubound(xx, dim=2) + do i = lbound(xx, dim=1), ubound(xx, dim=1) + xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx)) + end do + end do + end do + end do + lb = lbound(xx) + res = %loc(xx(lb(1),lb(2),lb(3),lb(4))) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select +end + +integer(c_intptr_t) function assumed_rank_pointer_f (xx) bind(c) result(res) + integer, pointer :: xx(..) + integer :: i, j, k, l, lb(4) + select rank (xx) + rank (4) + do l = lbound(xx, dim=4), ubound(xx, dim=4) + do k = lbound(xx, dim=3), ubound(xx, dim=3) + do j = lbound(xx, dim=2), ubound(xx, dim=2) + do i = lbound(xx, dim=1), ubound(xx, dim=1) + xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx)) + end do + end do + end do + end do + lb = lbound(xx) + res = %loc(xx(lb(1),lb(2),lb(3),lb(4))) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select +end + + +integer(c_intptr_t) function assumed_rank_f (xx) bind(c) result(res) + integer :: xx(..) + integer :: i, j, k, l + select rank (xx) + rank (4) + do l = 1, size(xx, dim=4) + do k = 1, size(xx, dim=3) + do j = 1, size(xx, dim=2) + do i = 1, size(xx, dim=1) + xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx)) + end do + end do + end do + end do + res = %loc(xx(1,1,1,1)) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select +end + +integer(c_intptr_t) function assumed_rank_cont_f (xx) bind(c) result(res) + integer, contiguous :: xx(..) + integer :: i, j, k, l + select rank (xx) + rank (4) + do l = 1, size(xx, dim=4) + do k = 1, size(xx, dim=3) + do j = 1, size(xx, dim=2) + do i = 1, size(xx, dim=1) + xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx)) + end do + end do + end do + end do + res = %loc(xx(1,1,1,1)) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select +end + +integer(c_intptr_t) function assumed_shape_f (xx) bind(c) result(res) + integer :: xx(:,:,:,:) + integer :: i, j, k, l + do l = 1, ubound(xx, dim=4) + do k = 1, ubound(xx, dim=3) + do j = 1, ubound(xx, dim=2) + do i = 1, ubound(xx, dim=1) + xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx)) + end do + end do + end do + end do + res = %loc(xx(1,1,1,1)) ! { dg-warning "Legacy Extension" } +end + +integer(c_intptr_t) function assumed_shape2_f (xx, n) bind(c) result(res) + integer, value :: n + integer :: xx(-n:, -n:, -n:, -n:) + integer :: i, j, k, l + do l = -n, ubound(xx, dim=4) + do k = -n, ubound(xx, dim=3) + do j = -n, ubound(xx, dim=2) + do i = -n, ubound(xx, dim=1) + xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx)) + end do + end do + end do + end do + res = %loc(xx(-n,-n,-n,-n)) ! { dg-warning "Legacy Extension" } +end + +integer(c_intptr_t) function assumed_shape_cont_f (xx) bind(c) result(res) + integer, contiguous :: xx(:,:,:,:) + integer :: i, j, k, l + do l = 1, ubound(xx, dim=4) + do k = 1, ubound(xx, dim=3) + do j = 1, ubound(xx, dim=2) + do i = 1, ubound(xx, dim=1) + xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx)) + end do + end do + end do + end do + res = %loc(xx(1,1,1,1)) ! { dg-warning "Legacy Extension" } +end + +integer(c_intptr_t) function assumed_shape2_cont_f (xx, n) bind(c) result(res) + integer, value :: n + integer, contiguous :: xx(-n:, -n:, -n:, -n:) + integer :: i, j, k, l + do l = -n, ubound(xx, dim=4) + do k = -n, ubound(xx, dim=3) + do j = -n, ubound(xx, dim=2) + do i = -n, ubound(xx, dim=1) + xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx)) + end do + end do + end do + end do + res = %loc(xx(-n,-n,-n,-n)) ! { dg-warning "Legacy Extension" } +end + +integer(c_intptr_t) function deferred_shape_alloc_f (xx) bind(c) result(res) + integer, allocatable :: xx(:,:,:,:) + integer :: i, j, k, l, lb(4) + do l = lbound(xx, dim=4), ubound(xx, dim=4) + do k = lbound(xx, dim=3), ubound(xx, dim=3) + do j = lbound(xx, dim=2), ubound(xx, dim=2) + do i = lbound(xx, dim=1), ubound(xx, dim=1) + xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx)) + end do + end do + end do + end do + lb = lbound(xx) + res = %loc(xx(lb(1),lb(2),lb(3),lb(4))) ! { dg-warning "Legacy Extension" } +end + +integer(c_intptr_t) function deferred_shape_pointer_f (xx) bind(c) result(res) + integer, pointer :: xx(:,:,:,:) + integer :: i, j, k, l, lb(4) + do l = lbound(xx, dim=4), ubound(xx, dim=4) + do k = lbound(xx, dim=3), ubound(xx, dim=3) + do j = lbound(xx, dim=2), ubound(xx, dim=2) + do i = lbound(xx, dim=1), ubound(xx, dim=1) + xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx)) + end do + end do + end do + end do + lb = lbound(xx) + res = %loc(xx(lb(1),lb(2),lb(3),lb(4))) ! { dg-warning "Legacy Extension" } +end +end module + + +use m +implicit none (type, external) +integer, dimension(10,10,10,10) :: var_init, var +target :: var +integer, allocatable, dimension(:,:,:,:) :: a1, a2 +integer, pointer, dimension(:,:,:,:) :: p1, p2 +integer(c_intptr_t) :: loc4 +integer :: i, k, j, l, cnt + +do l = 1, ubound(var_init, dim=4) + do k = 1, ubound(var_init, dim=3) + do j = 1, ubound(var_init, dim=2) + do i = 1, ubound(var_init, dim=1) + var_init(i,j,k,l) = get_n([i,j,k,l], lbound(var_init), shape(var_init)) + end do + end do + end do +end do + +! Fortran calls + +! ----- allocatable + pointer dummies ------- + +allocate(a1, mold=var_init) +allocate(p1, mold=var_init) +allocate(a2(-5:4,-10:-1,1:10,11:20)) +allocate(p2(-5:4,-10:-1,1:10,11:20)) + +a1(:,:,:,:) = var_init +loc4 = assumed_rank_alloc_f (a1) +cnt = size(a1) - check_unmod (a1) +call check (a1, loc4, .true., cnt) +call check2 (a1) + +a2(:,:,:,:) = var_init +loc4 = assumed_rank_alloc_f (a2) +cnt = size(a2) - check_unmod (a2) +call check (a2, loc4, .true., cnt) +call check2 (a2) + +a1(:,:,:,:) = var_init +loc4 = deferred_shape_alloc_f (a1) +cnt = size(a1) - check_unmod (a1) +call check (a1, loc4, .true., cnt) +call check2 (a1) + +a2(:,:,:,:) = var_init +loc4 = deferred_shape_alloc_f (a2) +cnt = size(a2) - check_unmod (a2) +call check (a2, loc4, .true., cnt) +call check2 (a2) + +deallocate(a1, a2) + +p1(:,:,:,:) = var_init +loc4 = assumed_rank_pointer_f (p1) +cnt = size(p1) - check_unmod (p1) +call check (p1, loc4, .true., cnt) +call check2 (p1) + +p2(:,:,:,:) = var_init +loc4 = assumed_rank_pointer_f (p2) +cnt = size(p2) - check_unmod (p2) +call check (p2, loc4, .true., cnt) +call check2 (p2) + +p1(:,:,:,:) = var_init +loc4 = deferred_shape_pointer_f (p1) +cnt = size(p1) - check_unmod (p1) +call check (p1, loc4, .true., cnt) +call check2 (p1) + +p2(:,:,:,:) = var_init +loc4 = deferred_shape_pointer_f (p2) +cnt = size(p2) - check_unmod (p2) +call check (p2, loc4, .true., cnt) +call check2 (p2) + +deallocate(p1, p2) + +! --- p => var(4:7,::3,::2,:) +var = var_init +p1 => var(4:7,::3,::2,:) +loc4 = assumed_rank_pointer_f (p1) +cnt = size(p1) - check_unmod (p1) +call check (p1, loc4, .false., cnt) +call check2 (p1) + +var = var_init +p2(-5:,-10:,1:,11:) => var(4:7,::3,::2,:) +loc4 = assumed_rank_pointer_f (p2) +cnt = size(p2) - check_unmod (p2) +call check (p2, loc4, .false., cnt) +call check2 (p2) + +var = var_init +p1 => var(4:7,::3,::2,:) +loc4 = deferred_shape_pointer_f (p1) +cnt = size(p1) - check_unmod (p1) +call check (p1, loc4, .false., cnt) +call check2 (p1) + +var = var_init +p2(-5:,-10:,1:,11:) => var(4:7,::3,::2,:) +loc4 = deferred_shape_pointer_f (p2) +cnt = size(p2) - check_unmod (p2) +call check (p2, loc4, .false., cnt) +call check2 (p2) + + + +! ----- nonallocatable + nonpointer dummies ------- + +var = var_init +loc4 = assumed_rank_f (var) +cnt = size(var) - check_unmod (var) +call check (var, loc4, .false., cnt) +call check2 (var) + +var = var_init +loc4 = assumed_shape_f (var) +cnt = size(var) - check_unmod (var) +call check (var, loc4, .false., cnt) +call check2 (var) + +var = var_init +loc4 = assumed_shape2_f (var, 99) +cnt = size(var) - check_unmod (var) +call check (var, loc4, .false., cnt) +call check2 (var) + +var = var_init +loc4 = assumed_rank_cont_f (var) +cnt = size(var) - check_unmod (var) +call check (var, loc4, .true., cnt) +call check2 (var) + +var = var_init +loc4 = assumed_shape_cont_f (var) +cnt = size(var) - check_unmod (var) +call check (var, loc4, .true., cnt) +call check2 (var) + +var = var_init +loc4 = assumed_shape2_cont_f (var, 99) +cnt = size(var) - check_unmod (var) +call check (var, loc4, .true., cnt) +call check2 (var) + +! --- var(4:7,::3,::2,:) + +var = var_init +loc4 = assumed_rank_f (var(4:7,::3,::2,:)) +cnt = size(var) - check_unmod (var) +call check (var(4:7,::3,::2,:), loc4, .false., cnt) +call check2 (var(4:7,::3,::2,:)) + +var = var_init +loc4 = assumed_shape_f (var(4:7,::3,::2,:)) +cnt = size(var) - check_unmod (var) +call check (var(4:7,::3,::2,:), loc4, .false., cnt) +call check2 (var(4:7,::3,::2,:)) + +var = var_init +loc4 = assumed_shape2_f (var(4:7,::3,::2,:), 99) +cnt = size(var) - check_unmod (var) +call check (var(4:7,::3,::2,:), loc4, .false., cnt) +call check2 (var(4:7,::3,::2,:)) + +var = var_init +loc4 = assumed_rank_cont_f (var(4:7,::3,::2,:)) +cnt = size(var) - check_unmod (var) +call check (var(4:7,::3,::2,:), loc4, .true., cnt) +call check2 (var(4:7,::3,::2,:)) + +var = var_init +loc4 = assumed_shape_cont_f (var(4:7,::3,::2,:)) +cnt = size(var) - check_unmod (var) +call check (var(4:7,::3,::2,:), loc4, .true., cnt) +call check2 (var(4:7,::3,::2,:)) + +var = var_init +loc4 = assumed_shape2_cont_f (var(4:7,::3,::2,:), 99) +cnt = size(var) - check_unmod (var) +call check (var(4:7,::3,::2,:), loc4, .true., cnt) +call check2 (var(4:7,::3,::2,:)) + + +! C calls + +! ----- allocatable + pointer dummies ------- + +allocate(a1, mold=var_init) +allocate(p1, mold=var_init) +allocate(a2(-5:4,-10:-1,1:10,11:20)) +allocate(p2(-5:4,-10:-1,1:10,11:20)) + +a1(:,:,:,:) = var_init +loc4 = assumed_rank_alloc_c (a1) +cnt = size(a1) - check_unmod (a1) +call check (a1, loc4, .true., cnt) +call check2 (a1) + +a2(:,:,:,:) = var_init +loc4 = assumed_rank_alloc_c (a2) +cnt = size(a2) - check_unmod (a2) +call check (a2, loc4, .true., cnt) +call check2 (a2) + +a1(:,:,:,:) = var_init +loc4 = deferred_shape_alloc_c (a1) +cnt = size(a1) - check_unmod (a1) +call check (a1, loc4, .true., cnt) +call check2 (a1) + +a2(:,:,:,:) = var_init +loc4 = deferred_shape_alloc_c (a2) +cnt = size(a2) - check_unmod (a2) +call check (a2, loc4, .true., cnt) +call check2 (a2) + +deallocate(a1, a2) + +p1(:,:,:,:) = var_init +loc4 = assumed_rank_pointer_c (p1) +cnt = size(p1) - check_unmod (p1) +call check (p1, loc4, .true., cnt) +call check2 (p1) + +p2(:,:,:,:) = var_init +loc4 = assumed_rank_pointer_c (p2) +cnt = size(p2) - check_unmod (p2) +call check (p2, loc4, .true., cnt) +call check2 (p2) + +p1(:,:,:,:) = var_init +loc4 = deferred_shape_pointer_c (p1) +cnt = size(p1) - check_unmod (p1) +call check (p1, loc4, .true., cnt) +call check2 (p1) + +p2(:,:,:,:) = var_init +loc4 = deferred_shape_pointer_c (p2) +cnt = size(p2) - check_unmod (p2) +call check (p2, loc4, .true., cnt) +call check2 (p2) + +deallocate(p1, p2) + +! --- p => var(4:7,::3,::2,:) +var = var_init +p1 => var(4:7,::3,::2,:) +loc4 = assumed_rank_pointer_c (p1) +cnt = size(p1) - check_unmod (p1) +call check (p1, loc4, .false., cnt) +call check2 (p1) + +var = var_init +p2(-5:,-10:,1:,11:) => var(4:7,::3,::2,:) +loc4 = assumed_rank_pointer_c (p2) +cnt = size(p2) - check_unmod (p2) +call check (p2, loc4, .false., cnt) +call check2 (p2) + +var = var_init +p1 => var(4:7,::3,::2,:) +loc4 = deferred_shape_pointer_c (p1) +cnt = size(p1) - check_unmod (p1) +call check (p1, loc4, .false., cnt) +call check2 (p1) + +var = var_init +p2(-5:,-10:,1:,11:) => var(4:7,::3,::2,:) +loc4 = deferred_shape_pointer_c (p2) +cnt = size(p2) - check_unmod (p2) +call check (p2, loc4, .false., cnt) +call check2 (p2) + + +! ----- nonallocatable + nonpointer dummies ------- + +var = var_init +loc4 = assumed_rank_c (var) +cnt = size(var) - check_unmod (var) +call check (var, loc4, .false., cnt) +call check2 (var) + +var = var_init +! calls assumed_shape_f +loc4 = assumed_shape_c (var, num=1) +cnt = size(var) - check_unmod (var) +call check (var, loc4, .false., cnt) +call check2 (var) + +var = var_init +! calls assumed_shape_cont_f +loc4 = assumed_shape_c (var, num=2) +cnt = size(var) - check_unmod (var) +call check (var, loc4, .true., cnt) +call check2 (var) + +var = var_init +! calls assumed_rank_cont_f +loc4 = assumed_shape_c (var, num=3) +cnt = size(var) - check_unmod (var) +call check (var, loc4, .true., cnt) +call check2 (var) + +var = var_init +loc4 = assumed_rank_cont_c (var) +cnt = size(var) - check_unmod (var) +call check (var, loc4, .true., cnt) +call check2 (var) + +var = var_init +loc4 = assumed_shape_cont_c (var) +cnt = size(var) - check_unmod (var) +call check (var, loc4, .true., cnt) +call check2 (var) + +! --- var(4:7,::3,::2,:) + +var = var_init +loc4 = assumed_rank_c (var(4:7,::3,::2,:)) +cnt = size(var) - check_unmod (var) +call check (var(4:7,::3,::2,:), loc4, .false., cnt) +call check2 (var(4:7,::3,::2,:)) + +var = var_init +! calls assumed_shape_f +loc4 = assumed_shape_c (var(4:7,::3,::2,:), num=4) +cnt = size(var) - check_unmod (var) +call check (var(4:7,::3,::2,:), loc4, .false., cnt) +call check2 (var(4:7,::3,::2,:)) + +var = var_init +! calls assumed_shape_cont_f +loc4 = assumed_shape_c (var(4:7,::3,::2,:), num=5) +cnt = size(var) - check_unmod (var) +call check (var(4:7,::3,::2,:), loc4, .true., cnt) +call check2 (var(4:7,::3,::2,:)) + +var = var_init +! calls assumed_rank_cont_f +loc4 = assumed_shape_c (var(4:7,::3,::2,:), num=6) +cnt = size(var) - check_unmod (var) +call check (var(4:7,::3,::2,:), loc4, .true., cnt) +call check2 (var(4:7,::3,::2,:)) + +var = var_init +loc4 = assumed_rank_cont_c (var(4:7,::3,::2,:)) +cnt = size(var) - check_unmod (var) +call check (var(4:7,::3,::2,:), loc4, .true., cnt) +call check2 (var(4:7,::3,::2,:)) + +var = var_init +loc4 = assumed_shape_cont_c (var(4:7,::3,::2,:)) +cnt = size(var) - check_unmod (var) +call check (var(4:7,::3,::2,:), loc4, .true., cnt) +call check2 (var(4:7,::3,::2,:)) + + +contains + +! Ensure that the rest is still okay +! Returns the number of elements >= 0 +integer function check_unmod (x) result(cnt) + integer, contiguous, intent(in) :: x(:,:,:,:) + integer :: i, k, j, l + cnt = 0 + do l = 1, ubound(x, dim=4) + do k = 1, ubound(x, dim=3) + do j = 1, ubound(x, dim=2) + do i = 1, ubound(x, dim=1) + if (x(i,j,k,l) >= 0) then + cnt = cnt + 1 + if (x(i,j,k,l) /= get_n([i,j,k,l], lbound(x), shape(x))) & + error stop 5 + endif + end do + end do + end do + end do +end + +subroutine check(x, loc1, cont, cnt) + integer, intent(in) :: x(:,:,:,:) + integer(c_intptr_t), intent(in), optional :: loc1 + logical, intent(in), optional :: cont ! dummy has CONTIGUOUS attr + integer, intent(in), optional :: cnt + integer(c_intptr_t) :: loc2 + integer :: i, k, j, l + if (present (loc1)) then + loc2 = %loc(x(1,1,1,1)) ! { dg-warning "Legacy Extension" } + if (is_contiguous (x) .or. .not.cont) then + if (loc1 /= loc2) error stop 1 + else + if (loc1 == loc2) error stop 2 + end if + if (cnt /= size(x)) error stop 3 + end if + do l = 1, ubound(x, dim=4) + do k = 1, ubound(x, dim=3) + do j = 1, ubound(x, dim=2) + do i = 1, ubound(x, dim=1) + if (x(i,j,k,l) /= -get_n([i,j,k,l], lbound(x), shape(x))) & + error stop 4 + end do + end do + end do + end do +end + +subroutine check2(x) + integer, contiguous, intent(in) :: x(:,:,:,:) + call check(x) +end subroutine +end diff --git a/gcc/testsuite/gfortran.dg/bind-c-contiguous-4.c b/gcc/testsuite/gfortran.dg/bind-c-contiguous-4.c new file mode 100644 index 0000000..cee1eb4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind-c-contiguous-4.c @@ -0,0 +1,370 @@ +#include <ISO_Fortran_binding.h> +#include <stdbool.h> +#include <string.h> + +struct loc_t { + intptr_t x, y, z; +}; + +typedef struct loc_t (*ftn_fn) (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_size_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_size_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_expl_size_f (CFI_cdesc_t *,CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_expl_size_in_f (CFI_cdesc_t *,CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_rank_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_rank_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_rank_cont_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_rank_cont_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_shape_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_shape_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_shape_cont_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_shape_cont_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); + +static void +basic_check(CFI_cdesc_t *x, bool is_cont) +{ + if (!x->base_addr) + __builtin_abort (); + if (x->elem_len != 3*sizeof(char)) + __builtin_abort (); + if (x->version != CFI_VERSION) + __builtin_abort (); + if (x->rank != 1) + __builtin_abort (); + if (x->attribute != CFI_attribute_other) + __builtin_abort (); + if (x->type != CFI_type_char) + __builtin_abort (); + if (x->dim[0].lower_bound != 0) + __builtin_abort (); + if (x->dim[0].extent != 3) + __builtin_abort (); + if (CFI_is_contiguous (x) != (x->elem_len == x->dim[0].sm)) + __builtin_abort (); + if (is_cont != CFI_is_contiguous (x)) + __builtin_abort (); +} + +static void +print_str (void *p, size_t len) +{ + __builtin_printf ("DEBUG: >"); + for (size_t i = 0; i < len; ++i) + __builtin_printf ("%c", ((const char*) p)[i]); + __builtin_printf ("<\n"); +} + +static void +check_str (CFI_cdesc_t *x, const char *str, const CFI_index_t subscripts[]) +{ + /* Avoid checking for '\0'. */ + if (strncmp ((const char*) CFI_address (x, subscripts), str, strlen(str)) != 0) + __builtin_abort (); +} + +static void +set_str (CFI_cdesc_t *x, const char *str, const CFI_index_t subscripts[]) +{ + char *p = CFI_address (x, subscripts); + size_t len = strlen (str); + if (x->elem_len != len) + __builtin_abort (); + for (size_t i = 0; i < len; ++i) + p[i] = str[i]; +} + +static struct loc_t +do_call (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num, bool intent_in, ftn_fn fn, bool is_cont, bool fort_cont) +{ + const CFI_index_t zero[1] = { 0 }; + const CFI_index_t one[1] = { 1 }; + const CFI_index_t two[1] = { 2 }; + struct loc_t addr1, addr2; + if (k != 3) + __builtin_abort (); + + if (num == 3) + { + if (x != NULL) + __builtin_abort (); + if (y != NULL) + __builtin_abort (); + if (z != NULL) + __builtin_abort (); + addr2 = fn (x, y, z, 3, num); + if (addr2.x != -1 || addr2.y != -1 || addr2.z != -1) + __builtin_abort (); + return addr2; + } + if (x == NULL) + __builtin_abort (); + if (y == NULL) + __builtin_abort (); + if (z == NULL) + __builtin_abort (); + basic_check (x, is_cont || num == 2); + basic_check (y, is_cont || num == 2); + basic_check (z, is_cont || num == 2); + if (!is_cont && num == 1) + { + check_str (x, "abc", zero); + check_str (x, "ghi", one); + check_str (x, "nop", two); + check_str (y, "abc", zero); + check_str (y, "ghi", one); + check_str (y, "nop", two); + check_str (z, "abc", zero); + check_str (z, "ghi", one); + check_str (z, "nop", two); + } + else if (num == 1) + { + if (strncmp ((const char*) x->base_addr, "abcghinop", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) y->base_addr, "abcghinop", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) z->base_addr, "abcghinop", 9) != 0) + __builtin_abort (); + } + else if (num == 2) + { + if (strncmp ((const char*) x->base_addr, "defghijlm", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) y->base_addr, "defghijlm", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) z->base_addr, "defghijlm", 9) != 0) + __builtin_abort (); + } + else + __builtin_abort (); + addr1.x = (intptr_t) x->base_addr; + addr1.y = (intptr_t) y->base_addr; + addr1.z = (intptr_t) z->base_addr; + addr2 = fn (x, y, z, 3, num); + if (!CFI_is_contiguous (x) && fort_cont) + { + /* Check for callee copy in/copy out. */ + if (addr1.x == addr2.x || addr1.x != (intptr_t) x->base_addr) + __builtin_abort (); + if (addr1.y == addr2.y || addr1.y != (intptr_t) y->base_addr) + __builtin_abort (); + if (addr1.z == addr2.z || addr1.z != (intptr_t) z->base_addr) + __builtin_abort (); + } + else + { + if (addr1.x != addr2.x || addr1.x != (intptr_t) x->base_addr) + __builtin_abort (); + if (addr1.y != addr2.y || addr1.y != (intptr_t) y->base_addr) + __builtin_abort (); + if (addr1.z != addr2.z || addr1.z != (intptr_t) z->base_addr) + __builtin_abort (); + } + // intent_in + if (intent_in && !is_cont && num == 1) + { + check_str (x, "abc", zero); + check_str (x, "ghi", one); + check_str (x, "nop", two); + check_str (y, "abc", zero); + check_str (y, "ghi", one); + check_str (y, "nop", two); + check_str (z, "abc", zero); + check_str (z, "ghi", one); + check_str (z, "nop", two); + } + else if (intent_in && num == 1) + { + if (strncmp ((const char*) x->base_addr, "abcghinop", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) y->base_addr, "abcghinop", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) z->base_addr, "abcghinop", 9) != 0) + __builtin_abort (); + } + else if (intent_in && num == 2) + { + if (strncmp ((const char*) x->base_addr, "defghijlm", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) y->base_addr, "defghijlm", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) z->base_addr, "defghijlm", 9) != 0) + __builtin_abort (); + } + else if (intent_in) + __builtin_abort (); + if (intent_in) + { + if (is_cont && num == 1) + { + /* Copy in - set the value to check that no copy out is done. */ + memcpy ((char*) x->base_addr, "123456789", 9); + memcpy ((char*) y->base_addr, "123456789", 9); + memcpy ((char*) z->base_addr, "123456789", 9); + } + return addr1; + } + // !intent_in + if (!is_cont && num == 1) + { + check_str (x, "ABC", zero); + check_str (x, "DEF", one); + check_str (x, "GHI", two); + check_str (y, "ABC", zero); + check_str (y, "DEF", one); + check_str (y, "GHI", two); + check_str (z, "ABC", zero); + check_str (z, "DEF", one); + check_str (z, "GHI", two); + } + else + { + if (strncmp ((const char*) x->base_addr, "ABCDEFGHI", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) y->base_addr, "ABCDEFGHI", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) z->base_addr, "ABCDEFGHI", 9) != 0) + __builtin_abort (); + } + return addr1; +} + +struct loc_t +char_assumed_size_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_assumed_size_f, true, false); +} + +struct loc_t +char_assumed_size_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_size_in_f, true, false); +} + +struct loc_t +char_expl_size_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_expl_size_f, true, false); +} + +struct loc_t +char_expl_size_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_expl_size_in_f, true, false); +} + +struct loc_t +char_assumed_rank_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_assumed_rank_f, false, false); +} + +struct loc_t +char_assumed_rank_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_rank_in_f, false, false); +} + +struct loc_t +char_assumed_rank_cont_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_assumed_rank_cont_f, true, false); +} + +struct loc_t +char_assumed_rank_cont_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_rank_cont_in_f, true, false); +} + +static void +reset_var (CFI_cdesc_t *x, int num) +{ + const CFI_index_t zero[1] = { 0 }; + const CFI_index_t one[1] = { 1 }; + const CFI_index_t two[1] = { 2 }; + + if (num == 1) + { + set_str (x, "abc", zero); + set_str (x, "ghi", one); + set_str (x, "nop", two); + } + else if (num == 2) + { + set_str (x, "def", zero); + set_str (x, "ghi", one); + set_str (x, "jlm", two); + } + else if (num == 3) + { + if (x != NULL) + __builtin_abort (); + } + else + __builtin_abort (); +} + +static void +reset_vars (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, int num) +{ + reset_var (x, num); + reset_var (y, num); + reset_var (z, num); +} + +struct loc_t +char_assumed_shape_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + /* Make use of having a noncontiguous argument to check that the callee + handles noncontiguous variables. */ + do_call (x, y, z, k, num, false, char_assumed_size_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, true, char_assumed_size_in_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, false, char_expl_size_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, true, char_expl_size_in_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, false, char_assumed_rank_cont_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, true, char_assumed_rank_cont_in_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, false, char_assumed_shape_cont_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, true, char_assumed_shape_cont_in_f, false, true); + /* Actual func call. */ + reset_vars (x, y, z, num); + return do_call (x, y, z, k, num, false, char_assumed_shape_f, false, false); +} + +struct loc_t +char_assumed_shape_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_shape_in_f, false, false); +} + +struct loc_t +char_assumed_shape_cont_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_assumed_shape_cont_f, true, false); +} + +struct loc_t +char_assumed_shape_cont_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_shape_cont_in_f, true, false); +} diff --git a/gcc/testsuite/gfortran.dg/bind-c-contiguous-4.f90 b/gcc/testsuite/gfortran.dg/bind-c-contiguous-4.f90 new file mode 100644 index 0000000..ab59b0b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind-c-contiguous-4.f90 @@ -0,0 +1,1720 @@ +! { dg-do run } +! +! Same test as bind-c-contiguous-1.* but with OPTIONAL +! +! { dg-additional-sources bind-c-contiguous-4.c } +! { dg-additional-options "-fcheck=all" } +! { dg-prune-output "command-line option '-fcheck=.*' is valid for Fortran but not for C" } + +! Fortran demands that with bind(C), the callee ensure that for +! * 'contiguous' +! * len=* with explicit/assumed-size arrays +! noncontiguous actual arguments are handled. +! (in without bind(C) in gfortran, caller handles the copy in/out + +! Additionally, for a bind(C) callee, a Fortran-written caller +! has to ensure the same (for contiguous + len=* to explicit-/assumed-size arrays) + +module m + use iso_c_binding, only: c_intptr_t, c_bool, c_loc, c_int + implicit none (type, external) + + type, bind(C) :: loc_t + integer(c_intptr_t) :: x, y, z + end type loc_t + +interface + type(loc_t) function char_assumed_size_c (xx, yy, zz, n, num) bind(C) + import :: loc_t, c_bool, c_int + integer(c_int), value :: n, num + character(len=*), optional :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*) + end function + + type(loc_t) function char_assumed_size_in_c (xx, yy, zz, n, num) bind(C) + import :: loc_t, c_bool, c_int + integer(c_int), value :: n, num + character(len=*), intent(in), optional :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*) + end function + + type(loc_t) function char_expl_size_c (xx, yy, zz, n, num) bind(c) + import :: loc_t, c_bool, c_int + integer(c_int), value :: n, num + character(len=*), optional :: xx(n), yy(n:n+3), zz(6:6, 3:n, 3:n+3) + end function + + type(loc_t) function char_expl_size_in_c (xx, yy, zz, n, num) bind(c) + import :: loc_t, c_bool, c_int + integer(c_int), value :: n, num + character(len=*), intent(in), optional :: xx(n), yy(n:n+3), zz(6:6, 3:n, 3:n+3) + end function + + type(loc_t) function char_assumed_rank_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), optional :: xx(..) + character(len=3), optional :: yy(..) + character(len=k), optional :: zz(..) + end function + + type(loc_t) function char_assumed_rank_in_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), intent(in), optional :: xx(..) + character(len=3), intent(in), optional :: yy(..) + character(len=k), intent(in), optional :: zz(..) + end function + + type(loc_t) function char_assumed_rank_cont_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), contiguous, optional :: xx(..) + character(len=3), contiguous, optional :: yy(..) + character(len=k), contiguous, optional :: zz(..) + end function + + type(loc_t) function char_assumed_rank_cont_in_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), contiguous, intent(in), optional :: xx(..) + character(len=3), contiguous, intent(in), optional :: yy(..) + character(len=k), contiguous, intent(in), optional :: zz(..) + end function + + type(loc_t) function char_assumed_shape_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), optional :: xx(:) + character(len=3), optional :: yy(5:) + character(len=k), optional :: zz(-k:) + end function + + type(loc_t) function char_assumed_shape_in_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), intent(in), optional :: xx(:) + character(len=3), intent(in), optional :: yy(5:) + character(len=k), intent(in), optional :: zz(-k:) + end function + + type(loc_t) function char_assumed_shape_cont_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), contiguous, optional :: xx(:) + character(len=3), contiguous, optional :: yy(5:) + character(len=k), contiguous, optional :: zz(-k:) + end function + + type(loc_t) function char_assumed_shape_cont_in_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), contiguous, intent(in), optional :: xx(:) + character(len=3), contiguous, intent(in), optional :: yy(5:) + character(len=k), contiguous, intent(in), optional :: zz(-k:) + end function +end interface + +contains + +type(loc_t) function char_assumed_size_f (xx, yy, zz, n, num) bind(c) result(res) + integer, value :: num, n + character(len=*), optional :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*) + if (num == 3) then + if (present (xx) .or. present (yy) .or. present (zz)) error stop 1 + res%x = -1; res%y = -1; res%z = -1 + return + end if + if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1 + print *, xx(1:3) + if (3 /= len(xx)) error stop 1 + if (3 /= len(yy)) error stop 1 + if (3 /= len(zz)) error stop 1 + if (1 /= lbound(xx,dim=1)) error stop 1 + if (3 /= lbound(yy,dim=1)) error stop 1 + if (6 /= lbound(zz,dim=1)) error stop 1 + if (3 /= lbound(zz,dim=2)) error stop 1 + if (3 /= lbound(zz,dim=3)) error stop 1 + if (1 /= size(zz,dim=1)) error stop 1 + if (1 /= size(zz,dim=2)) error stop 1 + if (6 /= ubound(zz,dim=1)) error stop 1 + if (3 /= ubound(zz,dim=2)) error stop 1 + if (num == 1) then + if (xx(1) /= "abc") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "nop") error stop 4 + if (yy(3) /= "abc") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "nop") error stop 4 + if (zz(6,n,3) /= "abc") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "nop") error stop 4 + else if (num == 2) then + if (xx(1) /= "def") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "jlm") error stop 4 + if (yy(3) /= "def") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "jlm") error stop 4 + if (zz(6,n,3) /= "def") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "jlm") error stop 4 + else + error stop 8 + endif + xx(1) = "ABC" + xx(2) = "DEF" + xx(3) = "GHI" + yy(3) = "ABC" + yy(4) = "DEF" + yy(5) = "GHI" + zz(6,n,3) = "ABC" + zz(6,n,4) = "DEF" + zz(6,n,5) = "GHI" + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + +type(loc_t) function char_assumed_size_in_f (xx, yy, zz, n, num) bind(c) result(res) + integer, value :: num, n + character(len=*), optional :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*) + intent(in) :: xx, yy, zz + if (num == 3) then + if (present (xx) .or. present (yy) .or. present (zz)) error stop 1 + res%x = -1; res%y = -1; res%z = -1 + return + end if + if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1 + print *, xx(1:3) + if (3 /= len(xx)) error stop 1 + if (3 /= len(yy)) error stop 1 + if (3 /= len(zz)) error stop 1 + if (1 /= lbound(xx,dim=1)) error stop 1 + if (3 /= lbound(yy,dim=1)) error stop 1 + if (6 /= lbound(zz,dim=1)) error stop 1 + if (3 /= lbound(zz,dim=2)) error stop 1 + if (3 /= lbound(zz,dim=3)) error stop 1 + if (1 /= size(zz,dim=1)) error stop 1 + if (1 /= size(zz,dim=2)) error stop 1 + if (6 /= ubound(zz,dim=1)) error stop 1 + if (3 /= ubound(zz,dim=2)) error stop 1 + if (num == 1) then + if (xx(1) /= "abc") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "nop") error stop 4 + if (yy(3) /= "abc") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "nop") error stop 4 + if (zz(6,n,3) /= "abc") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "nop") error stop 4 + else if (num == 2) then + if (xx(1) /= "def") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "jlm") error stop 4 + if (yy(3) /= "def") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "jlm") error stop 4 + if (zz(6,n,3) /= "def") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "jlm") error stop 4 + else + error stop 8 + endif + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } if (num == 1) then +end + +type(loc_t) function char_expl_size_f (xx, yy, zz, n, num) bind(c) result(res) + integer, value :: num, n + character(len=*), optional :: xx(n), yy(n:n+2), zz(6:6, 3:n, 3:n+2) + if (num == 3) then + if (present (xx) .or. present (yy) .or. present (zz)) error stop 1 + res%x = -1; res%y = -1; res%z = -1 + return + end if + if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1 + print *, xx(1:3) + if (3 /= len(xx)) error stop 1 + if (3 /= len(yy)) error stop 1 + if (3 /= len(zz)) error stop 1 + if (1 /= lbound(xx,dim=1)) error stop 1 + if (3 /= lbound(yy,dim=1)) error stop 1 + if (6 /= lbound(zz,dim=1)) error stop 1 + if (3 /= lbound(zz,dim=2)) error stop 1 + if (3 /= lbound(zz,dim=3)) error stop 1 + if (3 /= size(xx,dim=1)) error stop 1 + if (3 /= size(yy,dim=1)) error stop 1 + if (1 /= size(zz,dim=1)) error stop 1 + if (1 /= size(zz,dim=2)) error stop 1 + if (3 /= size(zz,dim=3)) error stop 1 + if (3 /= ubound(xx,dim=1)) error stop 1 + if (5 /= ubound(yy,dim=1)) error stop 1 + if (6 /= ubound(zz,dim=1)) error stop 1 + if (3 /= ubound(zz,dim=2)) error stop 1 + if (5 /= ubound(zz,dim=3)) error stop 1 + if (num == 1) then + if (xx(1) /= "abc") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "nop") error stop 4 + if (yy(3) /= "abc") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "nop") error stop 4 + if (zz(6,n,3) /= "abc") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "nop") error stop 4 + else if (num == 2) then + if (xx(1) /= "def") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "jlm") error stop 4 + if (yy(3) /= "def") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "jlm") error stop 4 + if (zz(6,n,3) /= "def") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "jlm") error stop 4 + else + error stop 8 + endif + xx(1) = "ABC" + xx(2) = "DEF" + xx(3) = "GHI" + yy(3) = "ABC" + yy(4) = "DEF" + yy(5) = "GHI" + zz(6,n,3) = "ABC" + zz(6,n,4) = "DEF" + zz(6,n,5) = "GHI" + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + +type(loc_t) function char_expl_size_in_f (xx, yy, zz, n, num) bind(c) result(res) + integer, value :: num, n + character(len=*), optional :: xx(n), yy(n:n+2), zz(6:6, 3:n, 3:n+2) + intent(in) :: xx, yy, zz + if (num == 3) then + if (present (xx) .or. present (yy) .or. present (zz)) error stop 1 + res%x = -1; res%y = -1; res%z = -1 + return + end if + if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1 + print *, xx(1:3) + if (3 /= len(xx)) error stop 1 + if (3 /= len(yy)) error stop 1 + if (3 /= len(zz)) error stop 1 + if (1 /= lbound(xx,dim=1)) error stop 1 + if (3 /= lbound(yy,dim=1)) error stop 1 + if (6 /= lbound(zz,dim=1)) error stop 1 + if (3 /= lbound(zz,dim=2)) error stop 1 + if (3 /= lbound(zz,dim=3)) error stop 1 + if (3 /= size(xx,dim=1)) error stop 1 + if (3 /= size(yy,dim=1)) error stop 1 + if (1 /= size(zz,dim=1)) error stop 1 + if (1 /= size(zz,dim=2)) error stop 1 + if (3 /= size(zz,dim=3)) error stop 1 + if (3 /= ubound(xx,dim=1)) error stop 1 + if (5 /= ubound(yy,dim=1)) error stop 1 + if (6 /= ubound(zz,dim=1)) error stop 1 + if (3 /= ubound(zz,dim=2)) error stop 1 + if (5 /= ubound(zz,dim=3)) error stop 1 + if (num == 1) then + if (xx(1) /= "abc") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "nop") error stop 4 + if (yy(3) /= "abc") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "nop") error stop 4 + if (zz(6,n,3) /= "abc") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "nop") error stop 4 + else if (num == 2) then + if (xx(1) /= "def") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "jlm") error stop 4 + if (yy(3) /= "def") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "jlm") error stop 4 + if (zz(6,n,3) /= "def") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "jlm") error stop 4 + else + error stop 8 + endif + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + + +type(loc_t) function char_assumed_rank_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*), optional :: xx(..) + character(len=3), optional :: yy(..) + character(len=k), optional :: zz(..) + if (num == 3) then + if (present (xx) .or. present (yy) .or. present (zz)) error stop 1 + res%x = -1; res%y = -1; res%z = -1 + return + end if + if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1 + if (3 /= len(xx)) error stop 40 + if (3 /= len(yy)) error stop 40 + if (3 /= len(zz)) error stop 40 + if (3 /= size(xx)) error stop 41 + if (3 /= size(yy)) error stop 41 + if (3 /= size(zz)) error stop 41 + if (1 /= rank(xx)) error stop 49 + if (1 /= rank(yy)) error stop 49 + if (1 /= rank(zz)) error stop 49 + if (1 /= lbound(xx, dim=1)) stop 49 + if (1 /= lbound(yy, dim=1)) stop 49 + if (1 /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (3 /= ubound(yy, dim=1)) stop 49 + if (3 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (is_contiguous (xx)) error stop 49 + if (is_contiguous (yy)) error stop 49 + if (is_contiguous (zz)) error stop 49 + else if (num == 2) then + if (.not. is_contiguous (xx)) error stop 49 + if (.not. is_contiguous (yy)) error stop 49 + if (.not. is_contiguous (zz)) error stop 49 + else + error stop 48 + end if + select rank (xx) + rank (1) + print *, xx(1:3) + if (num == 1) then + if (xx(1) /= "abc") error stop 42 + if (xx(2) /= "ghi") error stop 43 + if (xx(3) /= "nop") error stop 44 + else if (num == 2) then + if (xx(1) /= "def") error stop 45 + if (xx(2) /= "ghi") error stop 46 + if (xx(3) /= "jlm") error stop 47 + else + error stop 48 + endif + xx(1) = "ABC" + xx(2) = "DEF" + xx(3) = "GHI" + res%x = get_loc (xx) + rank default + error stop 99 + end select + select rank (yy) + rank (1) + print *, yy(1:3) + if (num == 1) then + if (yy(1) /= "abc") error stop 42 + if (yy(2) /= "ghi") error stop 43 + if (yy(3) /= "nop") error stop 44 + else if (num == 2) then + if (yy(1) /= "def") error stop 45 + if (yy(2) /= "ghi") error stop 46 + if (yy(3) /= "jlm") error stop 47 + else + error stop 48 + endif + yy(1) = "ABC" + yy(2) = "DEF" + yy(3) = "GHI" + res%y = get_loc (yy) + rank default + error stop 99 + end select + select rank (zz) + rank (1) + print *, zz(1:3) + if (num == 1) then + if (zz(1) /= "abc") error stop 42 + if (zz(2) /= "ghi") error stop 43 + if (zz(3) /= "nop") error stop 44 + else if (num == 2) then + if (zz(1) /= "def") error stop 45 + if (zz(2) /= "ghi") error stop 46 + if (zz(3) /= "jlm") error stop 47 + else + error stop 48 + endif + zz(1) = "ABC" + zz(2) = "DEF" + zz(3) = "GHI" + res%z = get_loc (zz) + rank default + error stop 99 + end select +contains + integer (c_intptr_t) function get_loc (arg) + character(len=*), target :: arg(:) + ! %loc does copy in/out if not simply contiguous + ! extra func needed because of 'target' attribute + get_loc = transfer (c_loc(arg), res%x) + end +end + +type(loc_t) function char_assumed_rank_in_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*), optional :: xx(..) + character(len=3), optional :: yy(..) + character(len=k), optional :: zz(..) + intent(in) :: xx, yy, zz + if (num == 3) then + if (present (xx) .or. present (yy) .or. present (zz)) error stop 1 + res%x = -1; res%y = -1; res%z = -1 + return + end if + if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1 + if (3 /= size(yy)) error stop 50 + if (3 /= len(yy)) error stop 51 + if (1 /= rank(yy)) error stop 59 + if (1 /= lbound(xx, dim=1)) stop 49 + if (1 /= lbound(yy, dim=1)) stop 49 + if (1 /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (3 /= ubound(yy, dim=1)) stop 49 + if (3 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (is_contiguous (xx)) error stop 59 + if (is_contiguous (yy)) error stop 59 + if (is_contiguous (zz)) error stop 59 + else if (num == 2) then + if (.not. is_contiguous (xx)) error stop 59 + if (.not. is_contiguous (yy)) error stop 59 + if (.not. is_contiguous (zz)) error stop 59 + else + error stop 48 + end if + select rank (xx) + rank (1) + print *, xx(1:3) + if (num == 1) then + if (xx(1) /= "abc") error stop 52 + if (xx(2) /= "ghi") error stop 53 + if (xx(3) /= "nop") error stop 54 + else if (num == 2) then + if (xx(1) /= "def") error stop 55 + if (xx(2) /= "ghi") error stop 56 + if (xx(3) /= "jlm") error stop 57 + else + error stop 58 + endif + res%x = get_loc(xx) + rank default + error stop 99 + end select + select rank (yy) + rank (1) + print *, yy(1:3) + if (num == 1) then + if (yy(1) /= "abc") error stop 52 + if (yy(2) /= "ghi") error stop 53 + if (yy(3) /= "nop") error stop 54 + else if (num == 2) then + if (yy(1) /= "def") error stop 55 + if (yy(2) /= "ghi") error stop 56 + if (yy(3) /= "jlm") error stop 57 + else + error stop 58 + endif + res%y = get_loc(yy) + rank default + error stop 99 + end select + select rank (zz) + rank (1) + print *, zz(1:3) + if (num == 1) then + if (zz(1) /= "abc") error stop 52 + if (zz(2) /= "ghi") error stop 53 + if (zz(3) /= "nop") error stop 54 + else if (num == 2) then + if (zz(1) /= "def") error stop 55 + if (zz(2) /= "ghi") error stop 56 + if (zz(3) /= "jlm") error stop 57 + else + error stop 58 + endif + res%z = get_loc(zz) + rank default + error stop 99 + end select +contains + integer (c_intptr_t) function get_loc (arg) + character(len=*), target :: arg(:) + ! %loc does copy in/out if not simply contiguous + ! extra func needed because of 'target' attribute + get_loc = transfer (c_loc(arg), res%x) + end +end + + + +type(loc_t) function char_assumed_rank_cont_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*), optional :: xx(..) + character(len=3), optional :: yy(..) + character(len=k), optional :: zz(..) + contiguous :: xx, yy, zz + if (num == 3) then + if (present (xx) .or. present (yy) .or. present (zz)) error stop 1 + res%x = -1; res%y = -1; res%z = -1 + return + end if + if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1 + if (3 /= len(xx)) error stop 60 + if (3 /= len(yy)) error stop 60 + if (3 /= len(zz)) error stop 60 + if (3 /= size(xx)) error stop 61 + if (3 /= size(yy)) error stop 61 + if (3 /= size(zz)) error stop 61 + if (1 /= rank(xx)) error stop 69 + if (1 /= rank(yy)) error stop 69 + if (1 /= rank(zz)) error stop 69 + if (1 /= lbound(xx, dim=1)) stop 49 + if (1 /= lbound(yy, dim=1)) stop 49 + if (1 /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (3 /= ubound(yy, dim=1)) stop 49 + if (3 /= ubound(zz, dim=1)) stop 49 + select rank (xx) + rank (1) + print *, xx(1:3) + if (num == 1) then + if (xx(1) /= "abc") error stop 62 + if (xx(2) /= "ghi") error stop 63 + if (xx(3) /= "nop") error stop 64 + else if (num == 2) then + if (xx(1) /= "def") error stop 65 + if (xx(2) /= "ghi") error stop 66 + if (xx(3) /= "jlm") error stop 67 + else + error stop 68 + endif + xx(1) = "ABC" + xx(2) = "DEF" + xx(3) = "GHI" + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select + select rank (yy) + rank (1) + print *, yy(1:3) + if (num == 1) then + if (yy(1) /= "abc") error stop 62 + if (yy(2) /= "ghi") error stop 63 + if (yy(3) /= "nop") error stop 64 + else if (num == 2) then + if (yy(1) /= "def") error stop 65 + if (yy(2) /= "ghi") error stop 66 + if (yy(3) /= "jlm") error stop 67 + else + error stop 68 + endif + yy(1) = "ABC" + yy(2) = "DEF" + yy(3) = "GHI" + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select + select rank (zz) + rank (1) + print *, zz(1:3) + if (num == 1) then + if (zz(1) /= "abc") error stop 62 + if (zz(2) /= "ghi") error stop 63 + if (zz(3) /= "nop") error stop 64 + else if (num == 2) then + if (zz(1) /= "def") error stop 65 + if (zz(2) /= "ghi") error stop 66 + if (zz(3) /= "jlm") error stop 67 + else + error stop 68 + endif + zz(1) = "ABC" + zz(2) = "DEF" + zz(3) = "GHI" + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select +end + +type(loc_t) function char_assumed_rank_cont_in_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*), optional :: xx(..) + character(len=3), optional :: yy(..) + character(len=k), optional :: zz(..) + intent(in) :: xx, yy, zz + contiguous :: xx, yy, zz + if (num == 3) then + if (present (xx) .or. present (yy) .or. present (zz)) error stop 1 + res%x = -1; res%y = -1; res%z = -1 + return + end if + if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1 + if (3 /= size(xx)) error stop 30 + if (3 /= size(yy)) error stop 30 + if (3 /= size(zz)) error stop 30 + if (3 /= len(xx)) error stop 31 + if (3 /= len(yy)) error stop 31 + if (3 /= len(zz)) error stop 31 + if (1 /= rank(xx)) error stop 69 + if (1 /= rank(yy)) error stop 69 + if (1 /= rank(zz)) error stop 69 + if (1 /= lbound(xx, dim=1)) stop 49 + if (1 /= lbound(yy, dim=1)) stop 49 + if (1 /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (3 /= ubound(yy, dim=1)) stop 49 + if (3 /= ubound(zz, dim=1)) stop 49 + select rank (xx) + rank (1) + print *, xx(1:3) + if (num == 1) then + if (xx(1) /= "abc") error stop 62 + if (xx(2) /= "ghi") error stop 63 + if (xx(3) /= "nop") error stop 64 + else if (num == 2) then + if (xx(1) /= "def") error stop 65 + if (xx(2) /= "ghi") error stop 66 + if (xx(3) /= "jlm") error stop 67 + else + error stop 68 + endif + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select + select rank (yy) + rank (1) + print *, yy(1:3) + if (num == 1) then + if (yy(1) /= "abc") error stop 62 + if (yy(2) /= "ghi") error stop 63 + if (yy(3) /= "nop") error stop 64 + else if (num == 2) then + if (yy(1) /= "def") error stop 65 + if (yy(2) /= "ghi") error stop 66 + if (yy(3) /= "jlm") error stop 67 + else + error stop 68 + endif + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select + select rank (zz) + rank (1) + print *, zz(1:3) + if (num == 1) then + if (zz(1) /= "abc") error stop 62 + if (zz(2) /= "ghi") error stop 63 + if (zz(3) /= "nop") error stop 64 + else if (num == 2) then + if (zz(1) /= "def") error stop 65 + if (zz(2) /= "ghi") error stop 66 + if (zz(3) /= "jlm") error stop 67 + else + error stop 68 + endif + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select +end + +type(loc_t) function char_assumed_shape_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*), optional :: xx(:) + character(len=3), optional :: yy(5:) + character(len=k), optional :: zz(-k:) + if (num == 3) then + if (present (xx) .or. present (yy) .or. present (zz)) error stop 1 + res%x = -1; res%y = -1; res%z = -1 + return + end if + if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1 + print *, xx(1:3) + if (3 /= len(xx)) error stop 70 + if (3 /= len(yy)) error stop 70 + if (3 /= len(zz)) error stop 70 + if (3 /= size(xx)) error stop 71 + if (3 /= size(yy)) error stop 71 + if (3 /= size(zz)) error stop 71 + if (1 /= lbound(xx, dim=1)) stop 49 + if (5 /= lbound(yy, dim=1)) stop 49 + if (-k /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (7 /= ubound(yy, dim=1)) stop 49 + if (-k+2 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (is_contiguous (xx)) error stop 79 + if (is_contiguous (yy)) error stop 79 + if (is_contiguous (zz)) error stop 79 + if (xx(1) /= "abc") error stop 72 + if (xx(2) /= "ghi") error stop 73 + if (xx(3) /= "nop") error stop 74 + if (yy(5) /= "abc") error stop 72 + if (yy(6) /= "ghi") error stop 73 + if (yy(7) /= "nop") error stop 74 + if (zz(-k) /= "abc") error stop 72 + if (zz(-k+1) /= "ghi") error stop 73 + if (zz(-k+2) /= "nop") error stop 74 + else if (num == 2) then + if (.not.is_contiguous (xx)) error stop 79 + if (.not.is_contiguous (yy)) error stop 79 + if (.not.is_contiguous (zz)) error stop 79 + if (xx(1) /= "def") error stop 72 + if (xx(2) /= "ghi") error stop 73 + if (xx(3) /= "jlm") error stop 74 + if (yy(5) /= "def") error stop 72 + if (yy(6) /= "ghi") error stop 73 + if (yy(7) /= "jlm") error stop 74 + if (zz(-k) /= "def") error stop 72 + if (zz(-k+1) /= "ghi") error stop 73 + if (zz(-k+2) /= "jlm") error stop 74 + else + error stop 78 + endif + xx(1) = "ABC" + xx(2) = "DEF" + xx(3) = "GHI" + yy(5) = "ABC" + yy(6) = "DEF" + yy(7) = "GHI" + zz(-k) = "ABC" + zz(-k+1) = "DEF" + zz(-k+2) = "GHI" + res%x = get_loc(xx) + res%y = get_loc(yy) + res%z = get_loc(zz) +contains + integer (c_intptr_t) function get_loc (arg) + character(len=*), target :: arg(:) + ! %loc does copy in/out if not simply contiguous + ! extra func needed because of 'target' attribute + get_loc = transfer (c_loc(arg), res%x) + end +end + +type(loc_t) function char_assumed_shape_in_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*), optional :: xx(:) + character(len=3), optional :: yy(5:) + character(len=k), optional :: zz(-k:) + intent(in) :: xx, yy, zz + if (num == 3) then + if (present (xx) .or. present (yy) .or. present (zz)) error stop 1 + res%x = -1; res%y = -1; res%z = -1 + return + end if + if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1 + print *, xx(1:3) + if (3 /= size(xx)) error stop 80 + if (3 /= size(yy)) error stop 80 + if (3 /= size(zz)) error stop 80 + if (3 /= len(xx)) error stop 81 + if (3 /= len(yy)) error stop 81 + if (3 /= len(zz)) error stop 81 + if (1 /= lbound(xx, dim=1)) stop 49 + if (5 /= lbound(yy, dim=1)) stop 49 + if (-k /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (7 /= ubound(yy, dim=1)) stop 49 + if (-k+2 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (is_contiguous (xx)) error stop 89 + if (is_contiguous (yy)) error stop 89 + if (is_contiguous (zz)) error stop 89 + if (xx(1) /= "abc") error stop 82 + if (xx(2) /= "ghi") error stop 83 + if (xx(3) /= "nop") error stop 84 + if (yy(5) /= "abc") error stop 82 + if (yy(6) /= "ghi") error stop 83 + if (yy(7) /= "nop") error stop 84 + if (zz(-k) /= "abc") error stop 82 + if (zz(-k+1) /= "ghi") error stop 83 + if (zz(-k+2) /= "nop") error stop 84 + else if (num == 2) then + if (.not.is_contiguous (xx)) error stop 89 + if (.not.is_contiguous (yy)) error stop 89 + if (.not.is_contiguous (zz)) error stop 89 + if (xx(1) /= "def") error stop 85 + if (xx(2) /= "ghi") error stop 86 + if (xx(3) /= "jlm") error stop 87 + if (yy(5) /= "def") error stop 85 + if (yy(6) /= "ghi") error stop 86 + if (yy(7) /= "jlm") error stop 87 + if (zz(-k) /= "def") error stop 85 + if (zz(-k+1) /= "ghi") error stop 86 + if (zz(-k+2) /= "jlm") error stop 87 + else + error stop 88 + endif + res%x = get_loc(xx) + res%y = get_loc(yy) + res%z = get_loc(zz) +contains + integer (c_intptr_t) function get_loc (arg) + character(len=*), target :: arg(:) + ! %loc does copy in/out if not simply contiguous + ! extra func needed because of 'target' attribute + get_loc = transfer (c_loc(arg), res%x) + end +end + + + +type(loc_t) function char_assumed_shape_cont_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*), optional :: xx(:) + character(len=3), optional :: yy(5:) + character(len=k), optional :: zz(-k:) + contiguous :: xx, yy, zz + if (num == 3) then + if (present (xx) .or. present (yy) .or. present (zz)) error stop 1 + res%x = -1; res%y = -1; res%z = -1 + return + end if + if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1 + print *, xx(1:3) + if (3 /= len(xx)) error stop 90 + if (3 /= len(yy)) error stop 90 + if (3 /= len(zz)) error stop 90 + if (3 /= size(xx)) error stop 91 + if (3 /= size(yy)) error stop 91 + if (3 /= size(zz)) error stop 91 + if (1 /= lbound(xx, dim=1)) stop 49 + if (5 /= lbound(yy, dim=1)) stop 49 + if (-k /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (7 /= ubound(yy, dim=1)) stop 49 + if (-k+2 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (xx(1) /= "abc") error stop 92 + if (xx(2) /= "ghi") error stop 93 + if (xx(3) /= "nop") error stop 94 + if (yy(5) /= "abc") error stop 92 + if (yy(6) /= "ghi") error stop 93 + if (yy(7) /= "nop") error stop 94 + if (zz(-k) /= "abc") error stop 92 + if (zz(-k+1) /= "ghi") error stop 93 + if (zz(-k+2) /= "nop") error stop 94 + else if (num == 2) then + if (xx(1) /= "def") error stop 92 + if (xx(2) /= "ghi") error stop 93 + if (xx(3) /= "jlm") error stop 94 + if (yy(5) /= "def") error stop 92 + if (yy(6) /= "ghi") error stop 93 + if (yy(7) /= "jlm") error stop 94 + if (zz(-k) /= "def") error stop 92 + if (zz(-k+1) /= "ghi") error stop 93 + if (zz(-k+2) /= "jlm") error stop 94 + else + error stop 98 + endif + xx(1) = "ABC" + xx(2) = "DEF" + xx(3) = "GHI" + yy(5) = "ABC" + yy(6) = "DEF" + yy(7) = "GHI" + zz(-k) = "ABC" + zz(-k+1) = "DEF" + zz(-k+2) = "GHI" + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + +type(loc_t) function char_assumed_shape_cont_in_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*), optional :: xx(:) + character(len=3), optional :: yy(5:) + character(len=k), optional :: zz(-k:) + intent(in) :: xx, yy, zz + contiguous :: xx, yy, zz + if (num == 3) then + if (present (xx) .or. present (yy) .or. present (zz)) error stop 1 + res%x = -1; res%y = -1; res%z = -1 + return + end if + if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1 + print *, xx(1:3) + if (3 /= size(xx)) error stop 100 + if (3 /= size(yy)) error stop 100 + if (3 /= size(zz)) error stop 100 + if (3 /= len(xx)) error stop 101 + if (3 /= len(yy)) error stop 101 + if (3 /= len(zz)) error stop 101 + if (1 /= lbound(xx, dim=1)) stop 49 + if (5 /= lbound(yy, dim=1)) stop 49 + if (-k /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (7 /= ubound(yy, dim=1)) stop 49 + if (-k+2 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (xx(1) /= "abc") error stop 102 + if (xx(2) /= "ghi") error stop 103 + if (xx(3) /= "nop") error stop 104 + if (yy(5) /= "abc") error stop 102 + if (yy(6) /= "ghi") error stop 103 + if (yy(7) /= "nop") error stop 104 + if (zz(-k) /= "abc") error stop 102 + if (zz(-k+1) /= "ghi") error stop 103 + if (zz(-k+2) /= "nop") error stop 104 + else if (num == 2) then + if (xx(1) /= "def") error stop 105 + if (xx(2) /= "ghi") error stop 106 + if (xx(3) /= "jlm") error stop 107 + if (yy(5) /= "def") error stop 105 + if (yy(6) /= "ghi") error stop 106 + if (yy(7) /= "jlm") error stop 107 + if (zz(-k) /= "def") error stop 105 + if (zz(-k+1) /= "ghi") error stop 106 + if (zz(-k+2) /= "jlm") error stop 107 + else + error stop 108 + endif + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + +end module + + +use m +implicit none (type, external) +character(len=3) :: a(6), a2(6), a3(6), a_init(6) +type(loc_t) :: loc3 + +a_init = ['abc', 'def', 'ghi', 'jlm', 'nop', 'qrs'] + +! -- Fortran: assumed size +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_f (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +loc3 = char_assumed_size_f (n=size(a(2:4)), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_in_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_in_f (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +loc3 = char_assumed_size_in_f (n=size(a(2:4)), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +! -- Fortran: explicit shape +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_f (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +loc3 = char_expl_size_f (n=size(a(2:4)), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_in_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_in_f (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +loc3 = char_expl_size_in_f (n=size(a(::2)), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +! -- Fortran: assumed rank +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_f (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +loc3 = char_assumed_rank_f (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +loc3 = char_assumed_rank_in_f (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +! -- Fortran: assumed rank contiguous +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +loc3 = char_assumed_rank_cont_f (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +loc3 = char_assumed_rank_cont_in_f (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +! -- Fortran: assumed shape +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_f (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +loc3 = char_assumed_shape_f (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +loc3 = char_assumed_shape_in_f (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +! -- Fortran: assumed shape contiguous +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +loc3 = char_assumed_shape_cont_f (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +loc3 = char_assumed_shape_cont_in_f (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + + +! --- character - call C directly -- + +! -- C: assumed size +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_c (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +loc3 = char_assumed_size_c (n=size(a(2:4)), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_in_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_in_c (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +loc3 = char_assumed_size_in_c (n=size(a(2:4)), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +! -- C: explicit shape +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_c (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +loc3 = char_expl_size_c (n=size(a(::2)), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_in_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_in_c (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +loc3 = char_expl_size_in_c (n=size(a(::2)), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +! -- C: assumed rank +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_c (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +loc3 = char_assumed_rank_c (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +loc3 = char_assumed_rank_in_c (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +! -- C: assumed rank contiguous +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +loc3 = char_assumed_rank_cont_c (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +loc3 = char_assumed_rank_cont_in_c (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +! -- C: assumed shape +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_c (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +loc3 = char_assumed_shape_c (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +loc3 = char_assumed_shape_in_c (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +! -- C: assumed shape contiguous +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +loc3 = char_assumed_shape_cont_c (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +loc3 = char_assumed_shape_cont_in_c (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 +end + +! { dg-output "At line 1003 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1003 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1003 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_f'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1024 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_in_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1024 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_in_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1024 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_in_f'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1046 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1046 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1046 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_f'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1067 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_in_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1067 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_in_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1067 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_in_f'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1132 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1132 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1132 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_f'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1153 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_in_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1153 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_in_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1153 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_in_f'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1218 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1218 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1218 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_f'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1239 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_in_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1239 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_in_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1239 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_in_f'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1264 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1264 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1264 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_c'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1285 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_in_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1285 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_in_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1285 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_in_c'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1307 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1307 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1307 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_c'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1328 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_in_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1328 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_in_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1328 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_in_c'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1393 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1393 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1393 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_c'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1414 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_in_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1414 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_in_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1414 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_in_c'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1479 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1479 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1479 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_c'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1500 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_in_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1500 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_in_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1500 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_in_c'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" diff --git a/gcc/testsuite/gfortran.dg/bind-c-contiguous-5.c b/gcc/testsuite/gfortran.dg/bind-c-contiguous-5.c new file mode 100644 index 0000000..0b7bae8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind-c-contiguous-5.c @@ -0,0 +1,446 @@ +#include <ISO_Fortran_binding.h> +#include <stdbool.h> +#include <string.h> + +struct loc_t { + intptr_t x, y, z; +}; + +typedef struct loc_t (*ftn_fn) (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_size_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_size_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_expl_size_f (CFI_cdesc_t *,CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_expl_size_in_f (CFI_cdesc_t *,CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_rank_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_rank_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_rank_cont_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_rank_cont_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_shape_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_shape_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_shape_cont_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_shape_cont_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); + +static void +basic_check(CFI_cdesc_t *x, bool is_cont) +{ + if (!x->base_addr) + __builtin_abort (); + if (x->elem_len != 3*(4*sizeof(char))) /* ucs4_char */ + __builtin_abort (); + if (x->version != CFI_VERSION) + __builtin_abort (); + if (x->rank != 1) + __builtin_abort (); + if (x->attribute != CFI_attribute_other) + __builtin_abort (); + if (x->type != CFI_type_ucs4_char) + __builtin_abort (); + if (x->dim[0].lower_bound != 0) + __builtin_abort (); + if (x->dim[0].extent != 3) + __builtin_abort (); + if (CFI_is_contiguous (x) != (x->elem_len == x->dim[0].sm)) + __builtin_abort (); + if (is_cont != CFI_is_contiguous (x)) + __builtin_abort (); +} + +static void +print_str (void *p, size_t len) +{ + __builtin_printf ("DEBUG: >"); + /* Use ' ' for '\0' */ + for (size_t i = 0; i < len*4; ++i) + __builtin_printf ("%c", ((const char*) p)[i] ? ((const char*) p)[i] : ' '); + __builtin_printf ("<\n"); +} + +static void +check_str (CFI_cdesc_t *x, const char *str, size_t n, const CFI_index_t subscripts[]) +{ + /* Avoid checking for '\0'. */ + if (memcmp ((const char*) CFI_address (x, subscripts), str, n) != 0) + __builtin_abort (); +} + +static void +set_str (CFI_cdesc_t *x, const char *str, size_t n, const CFI_index_t subscripts[]) +{ + char *p = CFI_address (x, subscripts); + if (x->elem_len != n) + __builtin_abort (); + for (size_t i = 0; i < n; ++i) + p[i] = str[i]; +} + +static struct loc_t +do_call (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num, bool intent_in, ftn_fn fn, bool is_cont, bool fort_cont) +{ + const CFI_index_t zero[1] = { 0 }; + const CFI_index_t one[1] = { 1 }; + const CFI_index_t two[1] = { 2 }; + struct loc_t addr1, addr2; + if (k != 3) + __builtin_abort (); + basic_check (x, is_cont || num == 2); + basic_check (y, is_cont || num == 2); + basic_check (z, is_cont || num == 2); + if (!is_cont && num == 1) + { +#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ + check_str (x, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero); + check_str (x, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one); + check_str (x, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two); + check_str (y, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero); + check_str (y, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one); + check_str (y, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two); + check_str (z, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero); + check_str (z, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one); + check_str (z, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two); +#elif __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ + check_str (x, "\0\0\0a\0\0\0b\0\0\0c", 3*4, zero); + check_str (x, "\0\0\0g\0\0\0h\0\0\0i", 3*4, one); + check_str (x, "\0\0\0n\0\0\0o\0\0\0p", 3*4, two); + check_str (y, "\0\0\0a\0\0\0b\0\0\0c", 3*4, zero); + check_str (y, "\0\0\0g\0\0\0h\0\0\0i", 3*4, one); + check_str (y, "\0\0\0n\0\0\0o\0\0\0p", 3*4, two); + check_str (z, "\0\0\0a\0\0\0b\0\0\0c", 3*4, zero); + check_str (z, "\0\0\0g\0\0\0h\0\0\0i", 3*4, one); + check_str (z, "\0\0\0n\0\0\0o\0\0\0p", 3*4, two); +#else +#error "Unsupported __BYTE_ORDER__" +#endif + } + else if (num == 1) + { +#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ + if (memcmp ((const char*) x->base_addr, "a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p\0\0\0", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) y->base_addr, "a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p\0\0\0", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) z->base_addr, "a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p\0\0\0", 9*4) != 0) + __builtin_abort (); +#else + if (memcmp ((const char*) x->base_addr, "\0\0\0a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) y->base_addr, "\0\0\0a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) z->base_addr, "\0\0\0a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p", 9*4) != 0) + __builtin_abort (); +#endif + } + else if (num == 2) + { +#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ + if (memcmp ((const char*) x->base_addr, "d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m\0\0\0", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) y->base_addr, "d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m\0\0\0", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) z->base_addr, "d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m\0\0\0", 9*4) != 0) + __builtin_abort (); +#else + if (memcmp ((const char*) x->base_addr, "\0\0\0d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) y->base_addr, "\0\0\0d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) z->base_addr, "\0\0\0d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m", 9*4) != 0) + __builtin_abort (); +#endif + } + else + __builtin_abort (); + addr1.x = (intptr_t) x->base_addr; + addr1.y = (intptr_t) y->base_addr; + addr1.z = (intptr_t) z->base_addr; + addr2 = fn (x, y, z, 3, num); + if (!CFI_is_contiguous (x) && fort_cont) + { + /* Check for callee copy in/copy out. */ + if (addr1.x == addr2.x || addr1.x != (intptr_t) x->base_addr) + __builtin_abort (); + if (addr1.y == addr2.y || addr1.y != (intptr_t) y->base_addr) + __builtin_abort (); + if (addr1.z == addr2.z || addr1.z != (intptr_t) z->base_addr) + __builtin_abort (); + } + else + { + if (addr1.x != addr2.x || addr1.x != (intptr_t) x->base_addr) + __builtin_abort (); + if (addr1.y != addr2.y || addr1.y != (intptr_t) y->base_addr) + __builtin_abort (); + if (addr1.z != addr2.z || addr1.z != (intptr_t) z->base_addr) + __builtin_abort (); + } + // intent_in + if (intent_in && !is_cont && num == 1) + { +#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ + check_str (x, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero); + check_str (x, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one); + check_str (x, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two); + check_str (y, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero); + check_str (y, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one); + check_str (y, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two); + check_str (z, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero); + check_str (z, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one); + check_str (z, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two); +#else + check_str (x, "\0\0\0a\0\0\0b\0\0\0c", 3*4, zero); + check_str (x, "\0\0\0g\0\0\0h\0\0\0i", 3*4, one); + check_str (x, "\0\0\0n\0\0\0o\0\0\0p", 3*4, two); + check_str (y, "\0\0\0a\0\0\0b\0\0\0c", 3*4, zero); + check_str (y, "\0\0\0g\0\0\0h\0\0\0i", 3*4, one); + check_str (y, "\0\0\0n\0\0\0o\0\0\0p", 3*4, two); + check_str (z, "\0\0\0a\0\0\0b\0\0\0c", 3*4, zero); + check_str (z, "\0\0\0g\0\0\0h\0\0\0i", 3*4, one); + check_str (z, "\0\0\0n\0\0\0o\0\0\0p", 3*4, two); +#endif + } + else if (intent_in && num == 1) + { +#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ + if (memcmp ((const char*) x->base_addr, "a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p\0\0\0", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) y->base_addr, "a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p\0\0\0", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) z->base_addr, "a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p\0\0\0", 9*4) != 0) + __builtin_abort (); +#else + if (memcmp ((const char*) x->base_addr, "\0\0\0a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) y->base_addr, "\0\0\0a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) z->base_addr, "\0\0\0a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p", 9*4) != 0) + __builtin_abort (); +#endif + } + else if (intent_in && num == 2) + { +#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ + if (memcmp ((const char*) x->base_addr, "d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m\0\0\0", 9) != 0) + __builtin_abort (); + if (memcmp ((const char*) y->base_addr, "d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m\0\0\0", 9) != 0) + __builtin_abort (); + if (memcmp ((const char*) z->base_addr, "d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m\0\0\0", 9) != 0) + __builtin_abort (); +#else + if (memcmp ((const char*) x->base_addr, "\0\0\0d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m", 9) != 0) + __builtin_abort (); + if (memcmp ((const char*) y->base_addr, "\0\0\0d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m", 9) != 0) + __builtin_abort (); + if (memcmp ((const char*) z->base_addr, "\0\0\0d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m", 9) != 0) + __builtin_abort (); +#endif + } + else if (intent_in) + __builtin_abort (); + if (intent_in) + { + if (is_cont && num == 1) + { + /* Copy in - set the value to check that no copy out is done. */ +#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ + memcpy ((char*) x->base_addr, "1\0\0\0""2\0\0\0""3\0\0\0""4\0\0\0""5\0\0\0""6\0\0\0""7\0\0\0""8\0\0\0""9\0\0\0", 9*4); + memcpy ((char*) y->base_addr, "1\0\0\0""2\0\0\0""3\0\0\0""4\0\0\0""5\0\0\0""6\0\0\0""7\0\0\0""8\0\0\0""9\0\0\0", 9*4); + memcpy ((char*) z->base_addr, "1\0\0\0""2\0\0\0""3\0\0\0""4\0\0\0""5\0\0\0""6\0\0\0""7\0\0\0""8\0\0\0""9\0\0\0", 9*4); +#else + memcpy ((char*) x->base_addr, "\0\0\0""1\0\0\0""2\0\0\0""3\0\0\0""4\0\0\0""5\0\0\0""6\0\0\0""7\0\0\0""8\0\0\0""9", 9*4); + memcpy ((char*) y->base_addr, "\0\0\0""1\0\0\0""2\0\0\0""3\0\0\0""4\0\0\0""5\0\0\0""6\0\0\0""7\0\0\0""8\0\0\0""9", 9*4); + memcpy ((char*) z->base_addr, "\0\0\0""1\0\0\0""2\0\0\0""3\0\0\0""4\0\0\0""5\0\0\0""6\0\0\0""7\0\0\0""8\0\0\0""9", 9*4); +#endif + } + return addr1; + } + // !intent_in + if (!is_cont && num == 1) + { +#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ + check_str (x, "A\0\0\0B\0\0\0C\0\0\0", 3*4, zero); + check_str (x, "D\0\0\0E\0\0\0F\0\0\0", 3*4, one); + check_str (x, "G\0\0\0H\0\0\0I\0\0\0", 3*4, two); + check_str (y, "A\0\0\0B\0\0\0C\0\0\0", 3*4, zero); + check_str (y, "D\0\0\0E\0\0\0F\0\0\0", 3*4, one); + check_str (y, "G\0\0\0H\0\0\0I\0\0\0", 3*4, two); + check_str (z, "A\0\0\0B\0\0\0C\0\0\0", 3*4, zero); + check_str (z, "D\0\0\0E\0\0\0F\0\0\0", 3*4, one); + check_str (z, "G\0\0\0H\0\0\0I\0\0\0", 3*4, two); +#else + check_str (x, "\0\0\0A\0\0\0B\0\0\0C", 3*4, zero); + check_str (x, "\0\0\0D\0\0\0E\0\0\0F", 3*4, one); + check_str (x, "\0\0\0G\0\0\0H\0\0\0I", 3*4, two); + check_str (y, "\0\0\0A\0\0\0B\0\0\0C", 3*4, zero); + check_str (y, "\0\0\0D\0\0\0E\0\0\0F", 3*4, one); + check_str (y, "\0\0\0G\0\0\0H\0\0\0I", 3*4, two); + check_str (z, "\0\0\0A\0\0\0B\0\0\0C", 3*4, zero); + check_str (z, "\0\0\0D\0\0\0E\0\0\0F", 3*4, one); + check_str (z, "\0\0\0G\0\0\0H\0\0\0I", 3*4, two); +#endif + } + else + { +#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ + if (memcmp ((const char*) x->base_addr, "A\0\0\0B\0\0\0C\0\0\0D\0\0\0E\0\0\0F\0\0\0G\0\0\0H\0\0\0I\0\0\0", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) y->base_addr, "A\0\0\0B\0\0\0C\0\0\0D\0\0\0E\0\0\0F\0\0\0G\0\0\0H\0\0\0I\0\0\0", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) z->base_addr, "A\0\0\0B\0\0\0C\0\0\0D\0\0\0E\0\0\0F\0\0\0G\0\0\0H\0\0\0I\0\0\0", 9*4) != 0) + __builtin_abort (); +#else + if (memcmp ((const char*) x->base_addr, "\0\0\0A\0\0\0B\0\0\0C\0\0\0D\0\0\0E\0\0\0F\0\0\0G\0\0\0H\0\0\0I", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) y->base_addr, "\0\0\0A\0\0\0B\0\0\0C\0\0\0D\0\0\0E\0\0\0F\0\0\0G\0\0\0H\0\0\0I", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) z->base_addr, "\0\0\0A\0\0\0B\0\0\0C\0\0\0D\0\0\0E\0\0\0F\0\0\0G\0\0\0H\0\0\0I", 9*4) != 0) + __builtin_abort (); +#endif + } + return addr1; +} + +struct loc_t +char_assumed_size_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_assumed_size_f, true, false); +} + +struct loc_t +char_assumed_size_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_size_in_f, true, false); +} + +struct loc_t +char_expl_size_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_expl_size_f, true, false); +} + +struct loc_t +char_expl_size_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_expl_size_in_f, true, false); +} + +struct loc_t +char_assumed_rank_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_assumed_rank_f, false, false); +} + +struct loc_t +char_assumed_rank_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_rank_in_f, false, false); +} + +struct loc_t +char_assumed_rank_cont_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_assumed_rank_cont_f, true, false); +} + +struct loc_t +char_assumed_rank_cont_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_rank_cont_in_f, true, false); +} + +static void +reset_var (CFI_cdesc_t *x, int num) +{ + const CFI_index_t zero[1] = { 0 }; + const CFI_index_t one[1] = { 1 }; + const CFI_index_t two[1] = { 2 }; + + if (num == 1) + { +#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ + set_str (x, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero); + set_str (x, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one); + set_str (x, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two); +#else + set_str (x, "\0\0\0a\0\0\0b\0\0\0c", 3*4, zero); + set_str (x, "\0\0\0g\0\0\0h\0\0\0i", 3*4, one); + set_str (x, "\0\0\0n\0\0\0o\0\0\0p", 3*4, two); +#endif + } + else if (num == 2) + { +#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ + set_str (x, "d\0\0\0e\0\0\0f\0\0\0", 3*4, zero); + set_str (x, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one); + set_str (x, "j\0\0\0l\0\0\0m\0\0\0", 3*4, two); +#else + set_str (x, "\0\0\0d\0\0\0e\0\0\0f", 3*4, zero); + set_str (x, "\0\0\0g\0\0\0h\0\0\0i", 3*4, one); + set_str (x, "\0\0\0j\0\0\0l\0\0\0m", 3*4, two); +#endif + } + else + __builtin_abort (); +} + +static void +reset_vars (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, int num) +{ + reset_var (x, num); + reset_var (y, num); + reset_var (z, num); +} + +struct loc_t +char_assumed_shape_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + /* Make use of having a noncontiguous argument to check that the callee + handles noncontiguous variables. */ + do_call (x, y, z, k, num, false, char_assumed_size_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, true, char_assumed_size_in_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, false, char_expl_size_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, true, char_expl_size_in_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, false, char_assumed_rank_cont_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, true, char_assumed_rank_cont_in_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, false, char_assumed_shape_cont_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, true, char_assumed_shape_cont_in_f, false, true); + /* Actual func call. */ + reset_vars (x, y, z, num); + return do_call (x, y, z, k, num, false, char_assumed_shape_f, false, false); +} + +struct loc_t +char_assumed_shape_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_shape_in_f, false, false); +} + +struct loc_t +char_assumed_shape_cont_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_assumed_shape_cont_f, true, false); +} + +struct loc_t +char_assumed_shape_cont_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_shape_cont_in_f, true, false); +} diff --git a/gcc/testsuite/gfortran.dg/bind-c-contiguous-5.f90 b/gcc/testsuite/gfortran.dg/bind-c-contiguous-5.f90 new file mode 100644 index 0000000..3eb2732 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind-c-contiguous-5.f90 @@ -0,0 +1,1574 @@ +! { dg-do run } +! { dg-additional-sources bind-c-contiguous-5.c } +! { dg-additional-options "-fcheck=all" } +! { dg-prune-output "command-line option '-fcheck=.*' is valid for Fortran but not for C" } +! ---- Same as bind-c-contiguous-1.f90 - but with kind=4 characters +! Fortran demands that with bind(C), the callee ensure that for +! * 'contiguous' +! * len=* with explicit/assumed-size arrays +! noncontiguous actual arguments are handled. +! (in without bind(C) in gfortran, caller handles the copy in/out + +! Additionally, for a bind(C) callee, a Fortran-written caller +! has to ensure the same (for contiguous + len=* to explicit-/assumed-size arrays) + +module m + use iso_c_binding, only: c_intptr_t, c_bool, c_loc, c_int + implicit none (type, external) + + type, bind(C) :: loc_t + integer(c_intptr_t) :: x, y, z + end type loc_t + +interface + type(loc_t) function char_assumed_size_c (xx, yy, zz, n, num) bind(C) + import :: loc_t, c_bool, c_int + integer(c_int), value :: n, num + character(kind=4, len=*) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*) + end function + + type(loc_t) function char_assumed_size_in_c (xx, yy, zz, n, num) bind(C) + import :: loc_t, c_bool, c_int + integer(c_int), value :: n, num + character(kind=4, len=*), intent(in) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*) + end function + + type(loc_t) function char_expl_size_c (xx, yy, zz, n, num) bind(c) + import :: loc_t, c_bool, c_int + integer(c_int), value :: n, num + character(kind=4, len=*) :: xx(n), yy(n:n+3), zz(6:6, 3:n, 3:n+3) + end function + + type(loc_t) function char_expl_size_in_c (xx, yy, zz, n, num) bind(c) + import :: loc_t, c_bool, c_int + integer(c_int), value :: n, num + character(kind=4, len=*), intent(in) :: xx(n), yy(n:n+3), zz(6:6, 3:n, 3:n+3) + end function + + type(loc_t) function char_assumed_rank_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(kind=4, len=*) :: xx(..) + character(kind=4, len=3) :: yy(..) + character(kind=4, len=k) :: zz(..) + end function + + type(loc_t) function char_assumed_rank_in_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(kind=4, len=*), intent(in) :: xx(..) + character(kind=4, len=3), intent(in) :: yy(..) + character(kind=4, len=k), intent(in) :: zz(..) + end function + + type(loc_t) function char_assumed_rank_cont_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(kind=4, len=*), contiguous :: xx(..) + character(kind=4, len=3), contiguous :: yy(..) + character(kind=4, len=k), contiguous :: zz(..) + end function + + type(loc_t) function char_assumed_rank_cont_in_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(kind=4, len=*), contiguous, intent(in) :: xx(..) + character(kind=4, len=3), contiguous, intent(in) :: yy(..) + character(kind=4, len=k), contiguous, intent(in) :: zz(..) + end function + + type(loc_t) function char_assumed_shape_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(kind=4, len=*) :: xx(:) + character(kind=4, len=3) :: yy(5:) + character(kind=4, len=k) :: zz(-k:) + end function + + type(loc_t) function char_assumed_shape_in_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(kind=4, len=*), intent(in) :: xx(:) + character(kind=4, len=3), intent(in) :: yy(5:) + character(kind=4, len=k), intent(in) :: zz(-k:) + end function + + type(loc_t) function char_assumed_shape_cont_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(kind=4, len=*), contiguous :: xx(:) + character(kind=4, len=3), contiguous :: yy(5:) + character(kind=4, len=k), contiguous :: zz(-k:) + end function + + type(loc_t) function char_assumed_shape_cont_in_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(kind=4, len=*), contiguous, intent(in) :: xx(:) + character(kind=4, len=3), contiguous, intent(in) :: yy(5:) + character(kind=4, len=k), contiguous, intent(in) :: zz(-k:) + end function +end interface + +contains + +type(loc_t) function char_assumed_size_f (xx, yy, zz, n, num) bind(c) result(res) + integer, value :: num, n + character(kind=4, len=*) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*) + print *, xx(1:3) + if (3 /= len(xx)) error stop 1 + if (3 /= len(yy)) error stop 1 + if (3 /= len(zz)) error stop 1 + if (1 /= lbound(xx,dim=1)) error stop 1 + if (3 /= lbound(yy,dim=1)) error stop 1 + if (6 /= lbound(zz,dim=1)) error stop 1 + if (3 /= lbound(zz,dim=2)) error stop 1 + if (3 /= lbound(zz,dim=3)) error stop 1 + if (1 /= size(zz,dim=1)) error stop 1 + if (1 /= size(zz,dim=2)) error stop 1 + if (6 /= ubound(zz,dim=1)) error stop 1 + if (3 /= ubound(zz,dim=2)) error stop 1 + if (num == 1) then + if (xx(1) /= 4_"abc") error stop 2 + if (xx(2) /= 4_"ghi") error stop 3 + if (xx(3) /= 4_"nop") error stop 4 + if (yy(3) /= 4_"abc") error stop 2 + if (yy(4) /= 4_"ghi") error stop 3 + if (yy(5) /= 4_"nop") error stop 4 + if (zz(6,n,3) /= 4_"abc") error stop 2 + if (zz(6,n,4) /= 4_"ghi") error stop 3 + if (zz(6,n,5) /= 4_"nop") error stop 4 + else if (num == 2) then + if (xx(1) /= 4_"def") error stop 2 + if (xx(2) /= 4_"ghi") error stop 3 + if (xx(3) /= 4_"jlm") error stop 4 + if (yy(3) /= 4_"def") error stop 2 + if (yy(4) /= 4_"ghi") error stop 3 + if (yy(5) /= 4_"jlm") error stop 4 + if (zz(6,n,3) /= 4_"def") error stop 2 + if (zz(6,n,4) /= 4_"ghi") error stop 3 + if (zz(6,n,5) /= 4_"jlm") error stop 4 + else + error stop 8 + endif + xx(1) = 4_"ABC" + xx(2) = 4_"DEF" + xx(3) = 4_"GHI" + yy(3) = 4_"ABC" + yy(4) = 4_"DEF" + yy(5) = 4_"GHI" + zz(6,n,3) = 4_"ABC" + zz(6,n,4) = 4_"DEF" + zz(6,n,5) = 4_"GHI" + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + +type(loc_t) function char_assumed_size_in_f (xx, yy, zz, n, num) bind(c) result(res) + integer, value :: num, n + character(kind=4, len=*) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*) + intent(in) :: xx, yy, zz + print *, xx(1:3) + if (3 /= len(xx)) error stop 1 + if (3 /= len(yy)) error stop 1 + if (3 /= len(zz)) error stop 1 + if (1 /= lbound(xx,dim=1)) error stop 1 + if (3 /= lbound(yy,dim=1)) error stop 1 + if (6 /= lbound(zz,dim=1)) error stop 1 + if (3 /= lbound(zz,dim=2)) error stop 1 + if (3 /= lbound(zz,dim=3)) error stop 1 + if (1 /= size(zz,dim=1)) error stop 1 + if (1 /= size(zz,dim=2)) error stop 1 + if (6 /= ubound(zz,dim=1)) error stop 1 + if (3 /= ubound(zz,dim=2)) error stop 1 + if (num == 1) then + if (xx(1) /= 4_"abc") error stop 2 + if (xx(2) /= 4_"ghi") error stop 3 + if (xx(3) /= 4_"nop") error stop 4 + if (yy(3) /= 4_"abc") error stop 2 + if (yy(4) /= 4_"ghi") error stop 3 + if (yy(5) /= 4_"nop") error stop 4 + if (zz(6,n,3) /= 4_"abc") error stop 2 + if (zz(6,n,4) /= 4_"ghi") error stop 3 + if (zz(6,n,5) /= 4_"nop") error stop 4 + else if (num == 2) then + if (xx(1) /= 4_"def") error stop 2 + if (xx(2) /= 4_"ghi") error stop 3 + if (xx(3) /= 4_"jlm") error stop 4 + if (yy(3) /= 4_"def") error stop 2 + if (yy(4) /= 4_"ghi") error stop 3 + if (yy(5) /= 4_"jlm") error stop 4 + if (zz(6,n,3) /= 4_"def") error stop 2 + if (zz(6,n,4) /= 4_"ghi") error stop 3 + if (zz(6,n,5) /= 4_"jlm") error stop 4 + else + error stop 8 + endif + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } if (num == 1) then +end + +type(loc_t) function char_expl_size_f (xx, yy, zz, n, num) bind(c) result(res) + integer, value :: num, n + character(kind=4, len=*) :: xx(n), yy(n:n+2), zz(6:6, 3:n, 3:n+2) + print *, xx(1:3) + if (3 /= len(xx)) error stop 1 + if (3 /= len(yy)) error stop 1 + if (3 /= len(zz)) error stop 1 + if (1 /= lbound(xx,dim=1)) error stop 1 + if (3 /= lbound(yy,dim=1)) error stop 1 + if (6 /= lbound(zz,dim=1)) error stop 1 + if (3 /= lbound(zz,dim=2)) error stop 1 + if (3 /= lbound(zz,dim=3)) error stop 1 + if (3 /= size(xx,dim=1)) error stop 1 + if (3 /= size(yy,dim=1)) error stop 1 + if (1 /= size(zz,dim=1)) error stop 1 + if (1 /= size(zz,dim=2)) error stop 1 + if (3 /= size(zz,dim=3)) error stop 1 + if (3 /= ubound(xx,dim=1)) error stop 1 + if (5 /= ubound(yy,dim=1)) error stop 1 + if (6 /= ubound(zz,dim=1)) error stop 1 + if (3 /= ubound(zz,dim=2)) error stop 1 + if (5 /= ubound(zz,dim=3)) error stop 1 + if (num == 1) then + if (xx(1) /= 4_"abc") error stop 2 + if (xx(2) /= 4_"ghi") error stop 3 + if (xx(3) /= 4_"nop") error stop 4 + if (yy(3) /= 4_"abc") error stop 2 + if (yy(4) /= 4_"ghi") error stop 3 + if (yy(5) /= 4_"nop") error stop 4 + if (zz(6,n,3) /= 4_"abc") error stop 2 + if (zz(6,n,4) /= 4_"ghi") error stop 3 + if (zz(6,n,5) /= 4_"nop") error stop 4 + else if (num == 2) then + if (xx(1) /= 4_"def") error stop 2 + if (xx(2) /= 4_"ghi") error stop 3 + if (xx(3) /= 4_"jlm") error stop 4 + if (yy(3) /= 4_"def") error stop 2 + if (yy(4) /= 4_"ghi") error stop 3 + if (yy(5) /= 4_"jlm") error stop 4 + if (zz(6,n,3) /= 4_"def") error stop 2 + if (zz(6,n,4) /= 4_"ghi") error stop 3 + if (zz(6,n,5) /= 4_"jlm") error stop 4 + else + error stop 8 + endif + xx(1) = 4_"ABC" + xx(2) = 4_"DEF" + xx(3) = 4_"GHI" + yy(3) = 4_"ABC" + yy(4) = 4_"DEF" + yy(5) = 4_"GHI" + zz(6,n,3) = 4_"ABC" + zz(6,n,4) = 4_"DEF" + zz(6,n,5) = 4_"GHI" + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + +type(loc_t) function char_expl_size_in_f (xx, yy, zz, n, num) bind(c) result(res) + integer, value :: num, n + character(kind=4, len=*) :: xx(n), yy(n:n+2), zz(6:6, 3:n, 3:n+2) + intent(in) :: xx, yy, zz + print *, xx(1:3) + if (3 /= len(xx)) error stop 1 + if (3 /= len(yy)) error stop 1 + if (3 /= len(zz)) error stop 1 + if (1 /= lbound(xx,dim=1)) error stop 1 + if (3 /= lbound(yy,dim=1)) error stop 1 + if (6 /= lbound(zz,dim=1)) error stop 1 + if (3 /= lbound(zz,dim=2)) error stop 1 + if (3 /= lbound(zz,dim=3)) error stop 1 + if (3 /= size(xx,dim=1)) error stop 1 + if (3 /= size(yy,dim=1)) error stop 1 + if (1 /= size(zz,dim=1)) error stop 1 + if (1 /= size(zz,dim=2)) error stop 1 + if (3 /= size(zz,dim=3)) error stop 1 + if (3 /= ubound(xx,dim=1)) error stop 1 + if (5 /= ubound(yy,dim=1)) error stop 1 + if (6 /= ubound(zz,dim=1)) error stop 1 + if (3 /= ubound(zz,dim=2)) error stop 1 + if (5 /= ubound(zz,dim=3)) error stop 1 + if (num == 1) then + if (xx(1) /= 4_"abc") error stop 2 + if (xx(2) /= 4_"ghi") error stop 3 + if (xx(3) /= 4_"nop") error stop 4 + if (yy(3) /= 4_"abc") error stop 2 + if (yy(4) /= 4_"ghi") error stop 3 + if (yy(5) /= 4_"nop") error stop 4 + if (zz(6,n,3) /= 4_"abc") error stop 2 + if (zz(6,n,4) /= 4_"ghi") error stop 3 + if (zz(6,n,5) /= 4_"nop") error stop 4 + else if (num == 2) then + if (xx(1) /= 4_"def") error stop 2 + if (xx(2) /= 4_"ghi") error stop 3 + if (xx(3) /= 4_"jlm") error stop 4 + if (yy(3) /= 4_"def") error stop 2 + if (yy(4) /= 4_"ghi") error stop 3 + if (yy(5) /= 4_"jlm") error stop 4 + if (zz(6,n,3) /= 4_"def") error stop 2 + if (zz(6,n,4) /= 4_"ghi") error stop 3 + if (zz(6,n,5) /= 4_"jlm") error stop 4 + else + error stop 8 + endif + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + + +type(loc_t) function char_assumed_rank_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(kind=4, len=*) :: xx(..) + character(kind=4, len=3) :: yy(..) + character(kind=4, len=k) :: zz(..) + if (3 /= len(xx)) error stop 40 + if (3 /= len(yy)) error stop 40 + if (3 /= len(zz)) error stop 40 + if (3 /= size(xx)) error stop 41 + if (3 /= size(yy)) error stop 41 + if (3 /= size(zz)) error stop 41 + if (1 /= rank(xx)) error stop 49 + if (1 /= rank(yy)) error stop 49 + if (1 /= rank(zz)) error stop 49 + if (1 /= lbound(xx, dim=1)) stop 49 + if (1 /= lbound(yy, dim=1)) stop 49 + if (1 /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (3 /= ubound(yy, dim=1)) stop 49 + if (3 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (is_contiguous (xx)) error stop 49 + if (is_contiguous (yy)) error stop 49 + if (is_contiguous (zz)) error stop 49 + else if (num == 2) then + if (.not. is_contiguous (xx)) error stop 49 + if (.not. is_contiguous (yy)) error stop 49 + if (.not. is_contiguous (zz)) error stop 49 + else + error stop 48 + end if + select rank (xx) + rank (1) + print *, xx(1:3) + if (num == 1) then + if (xx(1) /= 4_"abc") error stop 42 + if (xx(2) /= 4_"ghi") error stop 43 + if (xx(3) /= 4_"nop") error stop 44 + else if (num == 2) then + if (xx(1) /= 4_"def") error stop 45 + if (xx(2) /= 4_"ghi") error stop 46 + if (xx(3) /= 4_"jlm") error stop 47 + else + error stop 48 + endif + xx(1) = 4_"ABC" + xx(2) = 4_"DEF" + xx(3) = 4_"GHI" + res%x = get_loc (xx) + rank default + error stop 99 + end select + select rank (yy) + rank (1) + print *, yy(1:3) + if (num == 1) then + if (yy(1) /= 4_"abc") error stop 42 + if (yy(2) /= 4_"ghi") error stop 43 + if (yy(3) /= 4_"nop") error stop 44 + else if (num == 2) then + if (yy(1) /= 4_"def") error stop 45 + if (yy(2) /= 4_"ghi") error stop 46 + if (yy(3) /= 4_"jlm") error stop 47 + else + error stop 48 + endif + yy(1) = 4_"ABC" + yy(2) = 4_"DEF" + yy(3) = 4_"GHI" + res%y = get_loc (yy) + rank default + error stop 99 + end select + select rank (zz) + rank (1) + print *, zz(1:3) + if (num == 1) then + if (zz(1) /= 4_"abc") error stop 42 + if (zz(2) /= 4_"ghi") error stop 43 + if (zz(3) /= 4_"nop") error stop 44 + else if (num == 2) then + if (zz(1) /= 4_"def") error stop 45 + if (zz(2) /= 4_"ghi") error stop 46 + if (zz(3) /= 4_"jlm") error stop 47 + else + error stop 48 + endif + zz(1) = 4_"ABC" + zz(2) = 4_"DEF" + zz(3) = 4_"GHI" + res%z = get_loc (zz) + rank default + error stop 99 + end select +contains + integer (c_intptr_t) function get_loc (arg) + character(kind=4, len=*), target :: arg(:) + ! %loc does copy in/out if not simply contiguous + ! extra func needed because of 'target' attribute + get_loc = transfer (c_loc(arg), res%x) + end +end + +type(loc_t) function char_assumed_rank_in_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(kind=4, len=*) :: xx(..) + character(kind=4, len=3) :: yy(..) + character(kind=4, len=k) :: zz(..) + intent(in) :: xx, yy, zz + if (3 /= size(yy)) error stop 50 + if (3 /= len(yy)) error stop 51 + if (1 /= rank(yy)) error stop 59 + if (1 /= lbound(xx, dim=1)) stop 49 + if (1 /= lbound(yy, dim=1)) stop 49 + if (1 /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (3 /= ubound(yy, dim=1)) stop 49 + if (3 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (is_contiguous (xx)) error stop 59 + if (is_contiguous (yy)) error stop 59 + if (is_contiguous (zz)) error stop 59 + else if (num == 2) then + if (.not. is_contiguous (xx)) error stop 59 + if (.not. is_contiguous (yy)) error stop 59 + if (.not. is_contiguous (zz)) error stop 59 + else + error stop 48 + end if + select rank (xx) + rank (1) + print *, xx(1:3) + if (num == 1) then + if (xx(1) /= 4_"abc") error stop 52 + if (xx(2) /= 4_"ghi") error stop 53 + if (xx(3) /= 4_"nop") error stop 54 + else if (num == 2) then + if (xx(1) /= 4_"def") error stop 55 + if (xx(2) /= 4_"ghi") error stop 56 + if (xx(3) /= 4_"jlm") error stop 57 + else + error stop 58 + endif + res%x = get_loc(xx) + rank default + error stop 99 + end select + select rank (yy) + rank (1) + print *, yy(1:3) + if (num == 1) then + if (yy(1) /= 4_"abc") error stop 52 + if (yy(2) /= 4_"ghi") error stop 53 + if (yy(3) /= 4_"nop") error stop 54 + else if (num == 2) then + if (yy(1) /= 4_"def") error stop 55 + if (yy(2) /= 4_"ghi") error stop 56 + if (yy(3) /= 4_"jlm") error stop 57 + else + error stop 58 + endif + res%y = get_loc(yy) + rank default + error stop 99 + end select + select rank (zz) + rank (1) + print *, zz(1:3) + if (num == 1) then + if (zz(1) /= 4_"abc") error stop 52 + if (zz(2) /= 4_"ghi") error stop 53 + if (zz(3) /= 4_"nop") error stop 54 + else if (num == 2) then + if (zz(1) /= 4_"def") error stop 55 + if (zz(2) /= 4_"ghi") error stop 56 + if (zz(3) /= 4_"jlm") error stop 57 + else + error stop 58 + endif + res%z = get_loc(zz) + rank default + error stop 99 + end select +contains + integer (c_intptr_t) function get_loc (arg) + character(kind=4, len=*), target :: arg(:) + ! %loc does copy in/out if not simply contiguous + ! extra func needed because of 'target' attribute + get_loc = transfer (c_loc(arg), res%x) + end +end + + + +type(loc_t) function char_assumed_rank_cont_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(kind=4, len=*) :: xx(..) + character(kind=4, len=3) :: yy(..) + character(kind=4, len=k) :: zz(..) + contiguous :: xx, yy, zz + if (3 /= len(xx)) error stop 60 + if (3 /= len(yy)) error stop 60 + if (3 /= len(zz)) error stop 60 + if (3 /= size(xx)) error stop 61 + if (3 /= size(yy)) error stop 61 + if (3 /= size(zz)) error stop 61 + if (1 /= rank(xx)) error stop 69 + if (1 /= rank(yy)) error stop 69 + if (1 /= rank(zz)) error stop 69 + if (1 /= lbound(xx, dim=1)) stop 49 + if (1 /= lbound(yy, dim=1)) stop 49 + if (1 /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (3 /= ubound(yy, dim=1)) stop 49 + if (3 /= ubound(zz, dim=1)) stop 49 + select rank (xx) + rank (1) + print *, xx(1:3) + if (num == 1) then + if (xx(1) /= 4_"abc") error stop 62 + if (xx(2) /= 4_"ghi") error stop 63 + if (xx(3) /= 4_"nop") error stop 64 + else if (num == 2) then + if (xx(1) /= 4_"def") error stop 65 + if (xx(2) /= 4_"ghi") error stop 66 + if (xx(3) /= 4_"jlm") error stop 67 + else + error stop 68 + endif + xx(1) = 4_"ABC" + xx(2) = 4_"DEF" + xx(3) = 4_"GHI" + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select + select rank (yy) + rank (1) + print *, yy(1:3) + if (num == 1) then + if (yy(1) /= 4_"abc") error stop 62 + if (yy(2) /= 4_"ghi") error stop 63 + if (yy(3) /= 4_"nop") error stop 64 + else if (num == 2) then + if (yy(1) /= 4_"def") error stop 65 + if (yy(2) /= 4_"ghi") error stop 66 + if (yy(3) /= 4_"jlm") error stop 67 + else + error stop 68 + endif + yy(1) = 4_"ABC" + yy(2) = 4_"DEF" + yy(3) = 4_"GHI" + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select + select rank (zz) + rank (1) + print *, zz(1:3) + if (num == 1) then + if (zz(1) /= 4_"abc") error stop 62 + if (zz(2) /= 4_"ghi") error stop 63 + if (zz(3) /= 4_"nop") error stop 64 + else if (num == 2) then + if (zz(1) /= 4_"def") error stop 65 + if (zz(2) /= 4_"ghi") error stop 66 + if (zz(3) /= 4_"jlm") error stop 67 + else + error stop 68 + endif + zz(1) = 4_"ABC" + zz(2) = 4_"DEF" + zz(3) = 4_"GHI" + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select +end + +type(loc_t) function char_assumed_rank_cont_in_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(kind=4, len=*) :: xx(..) + character(kind=4, len=3) :: yy(..) + character(kind=4, len=k) :: zz(..) + intent(in) :: xx, yy, zz + contiguous :: xx, yy, zz + if (3 /= size(xx)) error stop 30 + if (3 /= size(yy)) error stop 30 + if (3 /= size(zz)) error stop 30 + if (3 /= len(xx)) error stop 31 + if (3 /= len(yy)) error stop 31 + if (3 /= len(zz)) error stop 31 + if (1 /= rank(xx)) error stop 69 + if (1 /= rank(yy)) error stop 69 + if (1 /= rank(zz)) error stop 69 + if (1 /= lbound(xx, dim=1)) stop 49 + if (1 /= lbound(yy, dim=1)) stop 49 + if (1 /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (3 /= ubound(yy, dim=1)) stop 49 + if (3 /= ubound(zz, dim=1)) stop 49 + select rank (xx) + rank (1) + print *, xx(1:3) + if (num == 1) then + if (xx(1) /= 4_"abc") error stop 62 + if (xx(2) /= 4_"ghi") error stop 63 + if (xx(3) /= 4_"nop") error stop 64 + else if (num == 2) then + if (xx(1) /= 4_"def") error stop 65 + if (xx(2) /= 4_"ghi") error stop 66 + if (xx(3) /= 4_"jlm") error stop 67 + else + error stop 68 + endif + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select + select rank (yy) + rank (1) + print *, yy(1:3) + if (num == 1) then + if (yy(1) /= 4_"abc") error stop 62 + if (yy(2) /= 4_"ghi") error stop 63 + if (yy(3) /= 4_"nop") error stop 64 + else if (num == 2) then + if (yy(1) /= 4_"def") error stop 65 + if (yy(2) /= 4_"ghi") error stop 66 + if (yy(3) /= 4_"jlm") error stop 67 + else + error stop 68 + endif + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select + select rank (zz) + rank (1) + print *, zz(1:3) + if (num == 1) then + if (zz(1) /= 4_"abc") error stop 62 + if (zz(2) /= 4_"ghi") error stop 63 + if (zz(3) /= 4_"nop") error stop 64 + else if (num == 2) then + if (zz(1) /= 4_"def") error stop 65 + if (zz(2) /= 4_"ghi") error stop 66 + if (zz(3) /= 4_"jlm") error stop 67 + else + error stop 68 + endif + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select +end + +type(loc_t) function char_assumed_shape_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(kind=4, len=*) :: xx(:) + character(kind=4, len=3) :: yy(5:) + character(kind=4, len=k) :: zz(-k:) + print *, xx(1:3) + if (3 /= len(xx)) error stop 70 + if (3 /= len(yy)) error stop 70 + if (3 /= len(zz)) error stop 70 + if (3 /= size(xx)) error stop 71 + if (3 /= size(yy)) error stop 71 + if (3 /= size(zz)) error stop 71 + if (1 /= lbound(xx, dim=1)) stop 49 + if (5 /= lbound(yy, dim=1)) stop 49 + if (-k /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (7 /= ubound(yy, dim=1)) stop 49 + if (-k+2 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (is_contiguous (xx)) error stop 79 + if (is_contiguous (yy)) error stop 79 + if (is_contiguous (zz)) error stop 79 + if (xx(1) /= 4_"abc") error stop 72 + if (xx(2) /= 4_"ghi") error stop 73 + if (xx(3) /= 4_"nop") error stop 74 + if (yy(5) /= 4_"abc") error stop 72 + if (yy(6) /= 4_"ghi") error stop 73 + if (yy(7) /= 4_"nop") error stop 74 + if (zz(-k) /= 4_"abc") error stop 72 + if (zz(-k+1) /= 4_"ghi") error stop 73 + if (zz(-k+2) /= 4_"nop") error stop 74 + else if (num == 2) then + if (.not.is_contiguous (xx)) error stop 79 + if (.not.is_contiguous (yy)) error stop 79 + if (.not.is_contiguous (zz)) error stop 79 + if (xx(1) /= 4_"def") error stop 72 + if (xx(2) /= 4_"ghi") error stop 73 + if (xx(3) /= 4_"jlm") error stop 74 + if (yy(5) /= 4_"def") error stop 72 + if (yy(6) /= 4_"ghi") error stop 73 + if (yy(7) /= 4_"jlm") error stop 74 + if (zz(-k) /= 4_"def") error stop 72 + if (zz(-k+1) /= 4_"ghi") error stop 73 + if (zz(-k+2) /= 4_"jlm") error stop 74 + else + error stop 78 + endif + xx(1) = 4_"ABC" + xx(2) = 4_"DEF" + xx(3) = 4_"GHI" + yy(5) = 4_"ABC" + yy(6) = 4_"DEF" + yy(7) = 4_"GHI" + zz(-k) = 4_"ABC" + zz(-k+1) = 4_"DEF" + zz(-k+2) = 4_"GHI" + res%x = get_loc(xx) + res%y = get_loc(yy) + res%z = get_loc(zz) +contains + integer (c_intptr_t) function get_loc (arg) + character(kind=4, len=*), target :: arg(:) + ! %loc does copy in/out if not simply contiguous + ! extra func needed because of 'target' attribute + get_loc = transfer (c_loc(arg), res%x) + end +end + +type(loc_t) function char_assumed_shape_in_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(kind=4, len=*) :: xx(:) + character(kind=4, len=3) :: yy(5:) + character(kind=4, len=k) :: zz(-k:) + intent(in) :: xx, yy, zz + print *, xx(1:3) + if (3 /= size(xx)) error stop 80 + if (3 /= size(yy)) error stop 80 + if (3 /= size(zz)) error stop 80 + if (3 /= len(xx)) error stop 81 + if (3 /= len(yy)) error stop 81 + if (3 /= len(zz)) error stop 81 + if (1 /= lbound(xx, dim=1)) stop 49 + if (5 /= lbound(yy, dim=1)) stop 49 + if (-k /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (7 /= ubound(yy, dim=1)) stop 49 + if (-k+2 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (is_contiguous (xx)) error stop 89 + if (is_contiguous (yy)) error stop 89 + if (is_contiguous (zz)) error stop 89 + if (xx(1) /= 4_"abc") error stop 82 + if (xx(2) /= 4_"ghi") error stop 83 + if (xx(3) /= 4_"nop") error stop 84 + if (yy(5) /= 4_"abc") error stop 82 + if (yy(6) /= 4_"ghi") error stop 83 + if (yy(7) /= 4_"nop") error stop 84 + if (zz(-k) /= 4_"abc") error stop 82 + if (zz(-k+1) /= 4_"ghi") error stop 83 + if (zz(-k+2) /= 4_"nop") error stop 84 + else if (num == 2) then + if (.not.is_contiguous (xx)) error stop 89 + if (.not.is_contiguous (yy)) error stop 89 + if (.not.is_contiguous (zz)) error stop 89 + if (xx(1) /= 4_"def") error stop 85 + if (xx(2) /= 4_"ghi") error stop 86 + if (xx(3) /= 4_"jlm") error stop 87 + if (yy(5) /= 4_"def") error stop 85 + if (yy(6) /= 4_"ghi") error stop 86 + if (yy(7) /= 4_"jlm") error stop 87 + if (zz(-k) /= 4_"def") error stop 85 + if (zz(-k+1) /= 4_"ghi") error stop 86 + if (zz(-k+2) /= 4_"jlm") error stop 87 + else + error stop 88 + endif + res%x = get_loc(xx) + res%y = get_loc(yy) + res%z = get_loc(zz) +contains + integer (c_intptr_t) function get_loc (arg) + character(kind=4, len=*), target :: arg(:) + ! %loc does copy in/out if not simply contiguous + ! extra func needed because of 'target' attribute + get_loc = transfer (c_loc(arg), res%x) + end +end + + + +type(loc_t) function char_assumed_shape_cont_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(kind=4, len=*) :: xx(:) + character(kind=4, len=3) :: yy(5:) + character(kind=4, len=k) :: zz(-k:) + contiguous :: xx, yy, zz + print *, xx(1:3) + if (3 /= len(xx)) error stop 90 + if (3 /= len(yy)) error stop 90 + if (3 /= len(zz)) error stop 90 + if (3 /= size(xx)) error stop 91 + if (3 /= size(yy)) error stop 91 + if (3 /= size(zz)) error stop 91 + if (1 /= lbound(xx, dim=1)) stop 49 + if (5 /= lbound(yy, dim=1)) stop 49 + if (-k /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (7 /= ubound(yy, dim=1)) stop 49 + if (-k+2 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (xx(1) /= 4_"abc") error stop 92 + if (xx(2) /= 4_"ghi") error stop 93 + if (xx(3) /= 4_"nop") error stop 94 + if (yy(5) /= 4_"abc") error stop 92 + if (yy(6) /= 4_"ghi") error stop 93 + if (yy(7) /= 4_"nop") error stop 94 + if (zz(-k) /= 4_"abc") error stop 92 + if (zz(-k+1) /= 4_"ghi") error stop 93 + if (zz(-k+2) /= 4_"nop") error stop 94 + else if (num == 2) then + if (xx(1) /= 4_"def") error stop 92 + if (xx(2) /= 4_"ghi") error stop 93 + if (xx(3) /= 4_"jlm") error stop 94 + if (yy(5) /= 4_"def") error stop 92 + if (yy(6) /= 4_"ghi") error stop 93 + if (yy(7) /= 4_"jlm") error stop 94 + if (zz(-k) /= 4_"def") error stop 92 + if (zz(-k+1) /= 4_"ghi") error stop 93 + if (zz(-k+2) /= 4_"jlm") error stop 94 + else + error stop 98 + endif + xx(1) = 4_"ABC" + xx(2) = 4_"DEF" + xx(3) = 4_"GHI" + yy(5) = 4_"ABC" + yy(6) = 4_"DEF" + yy(7) = 4_"GHI" + zz(-k) = 4_"ABC" + zz(-k+1) = 4_"DEF" + zz(-k+2) = 4_"GHI" + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + +type(loc_t) function char_assumed_shape_cont_in_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(kind=4, len=*) :: xx(:) + character(kind=4, len=3) :: yy(5:) + character(kind=4, len=k) :: zz(-k:) + intent(in) :: xx, yy, zz + contiguous :: xx, yy, zz + print *, xx(1:3) + if (3 /= size(xx)) error stop 100 + if (3 /= size(yy)) error stop 100 + if (3 /= size(zz)) error stop 100 + if (3 /= len(xx)) error stop 101 + if (3 /= len(yy)) error stop 101 + if (3 /= len(zz)) error stop 101 + if (1 /= lbound(xx, dim=1)) stop 49 + if (5 /= lbound(yy, dim=1)) stop 49 + if (-k /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (7 /= ubound(yy, dim=1)) stop 49 + if (-k+2 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (xx(1) /= 4_"abc") error stop 102 + if (xx(2) /= 4_"ghi") error stop 103 + if (xx(3) /= 4_"nop") error stop 104 + if (yy(5) /= 4_"abc") error stop 102 + if (yy(6) /= 4_"ghi") error stop 103 + if (yy(7) /= 4_"nop") error stop 104 + if (zz(-k) /= 4_"abc") error stop 102 + if (zz(-k+1) /= 4_"ghi") error stop 103 + if (zz(-k+2) /= 4_"nop") error stop 104 + else if (num == 2) then + if (xx(1) /= 4_"def") error stop 105 + if (xx(2) /= 4_"ghi") error stop 106 + if (xx(3) /= 4_"jlm") error stop 107 + if (yy(5) /= 4_"def") error stop 105 + if (yy(6) /= 4_"ghi") error stop 106 + if (yy(7) /= 4_"jlm") error stop 107 + if (zz(-k) /= 4_"def") error stop 105 + if (zz(-k+1) /= 4_"ghi") error stop 106 + if (zz(-k+2) /= 4_"jlm") error stop 107 + else + error stop 108 + endif + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + +end module + + +use m +implicit none (type, external) +character(kind=4, len=3) :: a(6), a2(6), a3(6), a_init(6) +type(loc_t) :: loc3 + +a_init = [4_'abc', 4_'def', 4_'ghi', 4_'jlm', 4_'nop', 4_'qrs'] + +! -- Fortran: assumed size +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_f (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_in_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_in_f (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- Fortran: explicit shape +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_f (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_in_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_in_f (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- Fortran: assumed rank +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_f (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- Fortran: assumed rank contiguous +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- Fortran: assumed shape +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_f (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- Fortran: assumed shape contiguous +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + + +! --- character - call C directly -- + +! -- C: assumed size +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_c (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_in_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_in_c (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- C: explicit shape +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_c (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_in_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_in_c (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- C: assumed rank +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_c (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- C: assumed rank contiguous +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- C: assumed shape +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_c (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- C: assumed shape contiguous +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 +end + + +! { dg-output "At line 928 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_f'(\n|\r\n|\r)" }" +! { dg-output "At line 928 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_f'(\n|\r\n|\r)" }" +! { dg-output "At line 928 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_f'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 946 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_in_f'(\n|\r\n|\r)" }" +! { dg-output "At line 946 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_in_f'(\n|\r\n|\r)" }" +! { dg-output "At line 946 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_in_f'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 965 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_f'(\n|\r\n|\r)" }" +! { dg-output "At line 965 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_f'(\n|\r\n|\r)" }" +! { dg-output "At line 965 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_f'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 983 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_in_f'(\n|\r\n|\r)" }" +! { dg-output "At line 983 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_in_f'(\n|\r\n|\r)" }" +! { dg-output "At line 983 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_in_f'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1039 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1039 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1039 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_f'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1057 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_in_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1057 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_in_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1057 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_in_f'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1113 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1113 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1113 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_f'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1131 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_in_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1131 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_in_f'(\n|\r\n|\r)" }" +! { dg-output "At line 1131 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_in_f'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1153 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1153 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1153 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_c'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1171 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_in_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1171 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_in_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1171 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_in_c'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1190 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1190 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1190 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_c'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1208 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_in_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1208 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_in_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1208 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_in_c'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1264 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1264 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1264 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_c'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1282 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_in_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1282 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_in_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1282 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_in_c'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1338 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1338 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1338 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_c'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" +! { dg-output "At line 1356 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_in_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1356 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_in_c'(\n|\r\n|\r)" }" +! { dg-output "At line 1356 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_in_c'(\n|\r\n|\r)" }" +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defghijlm(\n|\r\n|\r)" }" diff --git a/gcc/testsuite/gfortran.dg/bind-c-intent-out.f90 b/gcc/testsuite/gfortran.dg/bind-c-intent-out.f90 index 39822c0..d416fa5 100644 --- a/gcc/testsuite/gfortran.dg/bind-c-intent-out.f90 +++ b/gcc/testsuite/gfortran.dg/bind-c-intent-out.f90 @@ -1,4 +1,4 @@ -! { dg-do compile } +! { dg-do run } ! { dg-options "-fdump-tree-original" } ! ! PR fortran/91863 @@ -28,15 +28,20 @@ program p if (.not.allocated(a)) stop 1 if (any(shape(a) /= [3])) stop 2 if (lbound(a,1) /= 3 .or. ubound(a,1) /= 5) stop 3 + print *, a(0), a(1), a(2), a(3), a(4) + print *, a if (any(a /= [1, 2, 3])) stop 4 end program p ! "cfi" only appears in context of "a" -> bind-C descriptor -! the intent(out) implies freeing in the callee (!), hence the "free" +! the intent(out) implies freeing in the callee (!) (when implemented in Fortran), hence the "free" +! and also in the caller (when implemented in Fortran) ! It is the only 'free' as 'a' is part of the main program and, hence, implicitly has the SAVE attribute. ! The 'cfi = 0' appears before the call due to the deallocate and when preparing the C descriptor ! As cfi (i.e. the descriptor itself) is allocated in libgomp, it has to be freed after the call. ! { dg-final { scan-tree-dump-times "__builtin_free" 2 "original" } } -! { dg-final { scan-tree-dump-times "__builtin_free \\(cfi\\.\[0-9\]+\\);" 2 "original" } } -! { dg-final { scan-tree-dump-times "cfi\\.\[0-9\]+ = 0B;" 2 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free \\(_x->base_addr\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_x->base_addr = 0B;" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free \\(cfi\\.\[0-9\]+\\.base_addr\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "cfi\\.\[0-9\]+\\.base_addr = 0B;" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 b/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 index ede6eff..8dd7e8f 100644 --- a/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 +++ b/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 @@ -22,4 +22,32 @@ end ! { dg-final { scan-assembler-times "brasl\t%r\[0-9\]*,myBindC" 1 { target { s390*-*-* } } } } ! { dg-final { scan-assembler-times "bl \.myBindC" 1 { target { powerpc-ibm-aix* } } } } ! { dg-final { scan-assembler-times "add_u32\t\[sv\]\[0-9\]*, \[sv\]\[0-9\]*, myBindC@rel32@lo" 1 { target { amdgcn*-*-* } } } } -! { dg-final { scan-tree-dump-times "gfc_desc_to_cfi_desc \\\(&cfi\\." 1 "original" } } + + +! { dg-final { scan-tree-dump "parm...span = 4;" "original" } } +! { dg-final { scan-tree-dump "parm...dtype = {.elem_len=4, .rank=2, .type=1};" "original" } } +! { dg-final { scan-tree-dump "parm...dim\\\[0\\\].lbound = 1;" "original" } } +! { dg-final { scan-tree-dump "parm...dim\\\[0\\\].ubound = 4;" "original" } } +! { dg-final { scan-tree-dump "parm...dim\\\[0\\\].stride = 1;" "original" } } +! { dg-final { scan-tree-dump "parm...dim\\\[1\\\].lbound = 1;" "original" } } +! { dg-final { scan-tree-dump "parm...dim\\\[1\\\].ubound = 4;" "original" } } +! { dg-final { scan-tree-dump "parm...dim\\\[1\\\].stride = 4;" "original" } } +! { dg-final { scan-tree-dump "parm...data = \\(void \\*\\) &aa\\\[0\\\];" "original" } } +! { dg-final { scan-tree-dump "parm...offset = -5;" "original" } } +! { dg-final { scan-tree-dump "cfi...version = 1;" "original" } } +! { dg-final { scan-tree-dump "cfi...rank = 2;" "original" } } +! { dg-final { scan-tree-dump "cfi...type = 1025;" "original" } } +! { dg-final { scan-tree-dump "cfi...attribute = 2;" "original" } } +! { dg-final { scan-tree-dump "cfi...base_addr = parm.0.data;" "original" } } +! { dg-final { scan-tree-dump "cfi...elem_len = 4;" "original" } } +! { dg-final { scan-tree-dump "idx.2 = 0;" "original" } } + +! { dg-final { scan-tree-dump "if \\(idx.. <= 1\\) goto L..;" "original" } } +! { dg-final { scan-tree-dump "cfi...dim\\\[idx..\\\].lower_bound = 0;" "original" } } +! { dg-final { scan-tree-dump "cfi...dim\\\[idx..\\\].extent = \\(parm...dim\\\[idx..\\\].ubound - parm...dim\\\[idx..\\\].lbound\\) \\+ 1;" "original" } } +! { dg-final { scan-tree-dump "cfi...dim\\\[idx..\\\].sm = parm...dim\\\[idx..\\\].stride \\* parm...span;" "original" } } +! { dg-final { scan-tree-dump "idx.. = idx.. \\+ 1;" "original" } } + +! { dg-final { scan-tree-dump "test \\(&cfi..\\);" "original" } } + + diff --git a/gcc/testsuite/gfortran.dg/bind_c_char_10.f90 b/gcc/testsuite/gfortran.dg/bind_c_char_10.f90 index 3595851..7c6f4dc 100644 --- a/gcc/testsuite/gfortran.dg/bind_c_char_10.f90 +++ b/gcc/testsuite/gfortran.dg/bind_c_char_10.f90 @@ -466,15 +466,16 @@ program main end ! All arguments shall use array descriptors -! { dg-final { scan-tree-dump-times "void as1 \\(struct array01_character\\(kind=1\\) & restrict x1\\)" 1 "original" } } -! { dg-final { scan-tree-dump-times "void as2 \\(struct array01_character\\(kind=1\\) & restrict x2\\)" 1 "original" } } -! { dg-final { scan-tree-dump-times "void as4 \\(struct array01_character\\(kind=1\\) & restrict xstar\\)" 1 "original" } } -! { dg-final { scan-tree-dump-times "void as3 \\(struct array01_character\\(kind=1\\) & restrict xn, integer(kind=4) & restrict n) -! { dg-final { scan-tree-dump-times "void ar1 \\(struct array15_character\\(kind=1\\) & restrict x1\\)" 1 "original" } } -! { dg-final { scan-tree-dump-times "void ar2 \\(struct array15_character\\(kind=1\\) & restrict x2\\)" 1 "original" } } -! { dg-final { scan-tree-dump-times "void ar3 \\(struct array15_character\\(kind=1\\) & restrict xn, integer(kind=4) & restrict n) -! { dg-final { scan-tree-dump-times "void ar4 \\(struct array15_character\\(kind=1\\) & restrict xstar\\)" 1 "original" } } -! { dg-final { scan-tree-dump-times "void a5a \\(struct array01_character\\(kind=1\\) & restrict xcolon\\)" 1 "original" } } -! { dg-final { scan-tree-dump-times "void a5ar \\(struct array15_character\\(kind=1\\) & restrict xcolon\\)" 1 "original" } } -! { dg-final { scan-tree-dump-times "void a5p \\(struct array01_character\\(kind=1\\) & xcolon\\)" 1 "original" } } -! { dg-final { scan-tree-dump-times "void a5pr \\(struct array15_character\\(kind=1\\) & xcolon\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void as1 \\(struct CFI_cdesc_t01 & restrict _x1\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void as2 \\(struct CFI_cdesc_t01 & restrict _x2\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void as3 \\(struct CFI_cdesc_t01 & restrict _xn, integer\\(kind=4\\) & restrict n\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void as4 \\(struct CFI_cdesc_t01 & restrict _xstar\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void ar1 \\(struct CFI_cdesc_t & restrict _x1\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void ar2 \\(struct CFI_cdesc_t & restrict _x2\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void ar3 \\(struct CFI_cdesc_t & restrict _xn, integer\\(kind=4\\) & restrict n\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void ar4 \\(struct CFI_cdesc_t & restrict _xstar\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void a5ar \\(struct CFI_cdesc_t & restrict _xcolon\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void a5a \\(struct CFI_cdesc_t01 & restrict _xcolon\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void a5pr \\(struct CFI_cdesc_t & _xcolon\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void a5p \\(struct CFI_cdesc_t01 & _xcolon\\)" 1 "original" } } + diff --git a/gcc/testsuite/gfortran.dg/bind_c_char_8.f90 b/gcc/testsuite/gfortran.dg/bind_c_char_8.f90 index c6f406f..8e6413d 100644 --- a/gcc/testsuite/gfortran.dg/bind_c_char_8.f90 +++ b/gcc/testsuite/gfortran.dg/bind_c_char_8.f90 @@ -28,7 +28,7 @@ subroutine s3 (xn, n) bind(C) ! { dg-error "Character dummy argument 'xn' at .1. character(len=n) :: xn end -subroutine s4 (xstar) bind(C) ! { dg-error "Sorry, character dummy argument 'xstar' at .1. with assumed length is not yet supported for procedure 's4' with BIND\\(C\\) attribute" } +subroutine s4 (xstar) bind(C) character(len=*) :: xstar end @@ -85,7 +85,7 @@ subroutine az3 (xn, n) bind(C) ! { dg-error "Character dummy argument 'xn' at .1 character(len=n) :: xn(*) end -subroutine az4 (xstar) bind(C) ! { dg-error "Sorry, character dummy argument 'xstar' at .1. with assumed length is not yet supported for procedure 'az4' with BIND\\(C\\) attribute" } +subroutine az4 (xstar) bind(C) character(len=*) :: xstar(*) end @@ -104,7 +104,7 @@ subroutine ae3 (xn, n) bind(C) ! { dg-error "Character dummy argument 'xn' at .1 character(len=n) :: xn(9) end -subroutine ae4 (xstar) bind(C) ! { dg-error "Sorry, character dummy argument 'xstar' at .1. with assumed length is not yet supported for procedure 'ae4' with BIND\\(C\\) attribute" } +subroutine ae4 (xstar) bind(C) character(len=*) :: xstar(3) end @@ -128,7 +128,7 @@ subroutine s4a (xstar) bind(C) ! { dg-error "Allocatable character dummy argumen character(len=*), allocatable :: xstar end -subroutine s5a (xcolon) bind(C) ! { dg-error "Sorry, deferred-length scalar character dummy argument 'xcolon' at .1. of procedure 's5a' with BIND\\(C\\) not yet supported" } +subroutine s5a (xcolon) bind(C) character(len=:), allocatable :: xcolon end @@ -198,7 +198,7 @@ subroutine s4p (xstar) bind(C) ! { dg-error "Pointer character dummy argument 'x character(len=*), pointer :: xstar end -subroutine s5p (xcolon) bind(C) ! { dg-error "Sorry, deferred-length scalar character dummy argument 'xcolon' at .1. of procedure 's5p' with BIND\\(C\\) not yet supported" } +subroutine s5p (xcolon) bind(C) character(len=:), pointer :: xcolon end diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_4.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_4.f03 index f8c0f04..af9a588 100644 --- a/gcc/testsuite/gfortran.dg/binding_label_tests_4.f03 +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_4.f03 @@ -20,4 +20,4 @@ module C use A use B ! { dg-error "Cannot open module file" } end module C -! { dg-excess-errors "compilation terminated" } +! { dg-prune-output "compilation terminated" } diff --git a/gcc/testsuite/gfortran.dg/block_4.f08 b/gcc/testsuite/gfortran.dg/block_4.f08 index 4c63194..3ff52b0 100644 --- a/gcc/testsuite/gfortran.dg/block_4.f08 +++ b/gcc/testsuite/gfortran.dg/block_4.f08 @@ -15,4 +15,4 @@ PROGRAM main myname2: BLOCK END BLOCK ! { dg-error "Expected block name of 'myname2'" } END PROGRAM main ! { dg-error "Expecting END BLOCK" } -! { dg-excess-errors "Unexpected end of file" } +! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } diff --git a/gcc/testsuite/gfortran.dg/c-interop/allocatable-dummy.f90 b/gcc/testsuite/gfortran.dg/c-interop/allocatable-dummy.f90 index 4161a30..1d0cf65 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/allocatable-dummy.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/allocatable-dummy.f90 @@ -1,6 +1,6 @@ ! PR 101308 ! PR 92621(?) -! { dg-do run { xfail *-*-* } } +! { dg-do run } ! { dg-additional-sources "allocatable-dummy-c.c dump-descriptors.c" } ! { dg-additional-options "-g" } ! diff --git a/gcc/testsuite/gfortran.dg/c-interop/c1255-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/c1255-1.f90 index 62fee2c..fb91107 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/c1255-1.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/c1255-1.f90 @@ -56,7 +56,7 @@ module m end subroutine ! dummy is assumed length character variable - subroutine s6 (x) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } } + subroutine s6 (x) bind (c) use ISO_C_BINDING implicit none character(len=*) :: x diff --git a/gcc/testsuite/gfortran.dg/c-interop/c407c-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/c407c-1.f90 index c77e6ac..699f75f 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/c407c-1.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/c407c-1.f90 @@ -44,7 +44,7 @@ subroutine s2 (x) implicit none type(*) :: x(*) - call g (x, 1) ! { dg-error "Assumed.type" } + 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. diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535c-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535c-1.f90 index b404713..2158c35 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/c535c-1.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/c535c-1.f90 @@ -11,77 +11,154 @@ ! This test file contains tests that are expected to issue diagnostics ! for invalid code. -module m - +module t type :: t1 integer :: id real :: xyz(3) end type +end module -contains +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 - subroutine s1_nonpolymorphic (x, y) - type(t1) :: x(..) - type(t1), intent(out) :: y(..) - end subroutine +contains - subroutine s1_polymorphic (x, y) ! { dg-bogus "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } } - class(t1) :: x(..) - class(t1), intent(out) :: y(..) + ! 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 s1_unlimited_polymorphic (x, y) ! { dg-bogus "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } } - class(*) :: x(..) - class(*), intent(out) :: y(..) + 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 - - ! These calls should all be OK as they do not involve assumed-size or - ! assumed-rank actual arguments. - subroutine test_known_size (a1, a2, n) + subroutine test_known_size_unlimited_polymorphic (a1, a2, n) integer :: n - type(t1) :: a1(n,n), a2(n) + class(*) :: a1(n,n), a2(n) + call upoly (a1, a2) + end subroutine - call s1_nonpolymorphic (a1, a2) - call s1_polymorphic (a1, a2) - call s1_unlimited_polymorphic (a1, a2) + ! 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 calls to the polymorphic functions should be rejected - ! with an assumed-size array argument. - subroutine test_assumed_size (a1, a2) + ! 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 - call s1_nonpolymorphic (a1, a2) - call s1_polymorphic (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } } - call s1_unlimited_polymorphic (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } } + ! 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 - ! These calls should be OK. - subroutine test_assumed_rank_pointer (a1, a2) + ! Pointer/allocatable assumed-rank should be OK. + subroutine test_pointer_nonpolymorphic (a1, a2) type(t1), pointer :: a1(..), a2(..) - - call s1_nonpolymorphic (a1, a2) - call s1_polymorphic (a1, a2) - call s1_unlimited_polymorphic (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 - ! These calls should be OK. - subroutine test_assumed_rank_allocatable (a1, a2) + subroutine test_allocatable_nonpolymorphic (a1, a2) type(t1), allocatable :: a1(..), a2(..) - - call s1_nonpolymorphic (a1, a2) - call s1_polymorphic (a1, a2) - call s1_unlimited_polymorphic (a1, a2) + call poly (a1, a2) + call upoly (a1, a2) end subroutine - - ! The calls to the polymorphic functions should be rejected - ! with a nonallocatable nonpointer assumed-rank actual argument. - subroutine test_assumed_rank_plain (a1, a2) - type(t1) :: a1(..), a2(..) - - call s1_nonpolymorphic (a1, a2) - call s1_polymorphic (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } } - call s1_unlimited_polymorphic (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } } + 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 diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535c-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535c-2.f90 index db15ece..f232efa 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/c535c-2.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/c535c-2.f90 @@ -45,7 +45,7 @@ contains subroutine test_assumed_size (a1, a2) type(t1) :: a1(*), a2(*) - call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } } + call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" } end subroutine ! This call should be OK. @@ -67,7 +67,7 @@ contains subroutine test_assumed_rank_plain (a1, a2) type(t1) :: a1(..), a2(..) - call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } } + call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" } end subroutine end module diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535c-3.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535c-3.f90 index 5c224b1..50840a1 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/c535c-3.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/c535c-3.f90 @@ -1,6 +1,5 @@ ! PR 54753 ! { dg-do compile } -! { dg-ice "pr54753" } ! ! TS 29113 ! C535c If an assumed-size or nonallocatable nonpointer assumed-rank @@ -45,7 +44,7 @@ contains subroutine test_assumed_size (a1, a2) type(t1) :: a1(*), a2(*) - call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } } + call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" } end subroutine ! This call should be OK. @@ -67,7 +66,7 @@ contains subroutine test_assumed_rank_plain (a1, a2) type(t1) :: a1(..), a2(..) - call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } } + call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" } end subroutine end module diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535c-4.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535c-4.f90 index ecbb181..dc380ba 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/c535c-4.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/c535c-4.f90 @@ -1,6 +1,5 @@ ! PR 54753 ! { dg-do compile } -! { dg-ice "pr54753" } ! ! TS 29113 ! C535c If an assumed-size or nonallocatable nonpointer assumed-rank @@ -45,7 +44,7 @@ contains subroutine test_assumed_size (a1, a2) type(t1) :: a1(*), a2(*) - call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } } + call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" } end subroutine ! This call should be OK. @@ -67,7 +66,7 @@ contains subroutine test_assumed_rank_plain (a1, a2) type(t1) :: a1(..), a2(..) - call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } } + call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" } end subroutine end module diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-5-c.c b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-5-c.c index 12464b5..320a354 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-5-c.c +++ b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-5-c.c @@ -1,6 +1,5 @@ #include <stdlib.h> #include <stdio.h> -#include <alloca.h> #include <ISO_Fortran_binding.h> #include "dump-descriptors.h" @@ -8,12 +7,18 @@ 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; - char *adata = (char *) alloca (n); + + /* Use a fixed-size static buffer instead of allocating one dynamically. */ + if (n > BUFSIZE) + abort (); /* Fill in adesc. */ check_CFI_status ("CFI_establish", diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-5.f90 b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-5.f90 index f178bb8..b5edf52 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-5.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-5.f90 @@ -7,7 +7,7 @@ ! 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") ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } } +subroutine ftest (a, n) bind (c, name="ftest") use iso_c_binding character(kind=C_CHAR, len=*) :: a integer(C_INT), value :: n diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-3.f90 b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-3.f90 index 5e5f595..d85a78a 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-3.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-3.f90 @@ -1,5 +1,5 @@ ! PR 92621 (?) -! { dg-do run { xfail *-*-* } } +! { dg-do run } ! { dg-additional-sources "cf-out-descriptor-3-c.c dump-descriptors.c" } ! { dg-additional-options "-g" } ! diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-4.f90 b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-4.f90 index 082610c..e14c757 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-4.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-4.f90 @@ -1,5 +1,5 @@ ! PR 92621 (?) -! { dg-do run { xfail *-*-* } } +! { dg-do run } ! { dg-additional-sources "cf-out-descriptor-4-c.c dump-descriptors.c" } ! { dg-additional-options "-g" } ! diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-5.f90 b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-5.f90 index ff1e31d..b0dd20c 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-5.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-5.f90 @@ -6,7 +6,7 @@ ! 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") ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } } +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 @@ -20,13 +20,13 @@ program testit implicit none interface - subroutine ctest (a, n) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } } + 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) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } } + subroutine ftest (a, n) bind (c) use iso_c_binding character(kind=C_CHAR, len=*), intent(out) :: a integer(C_INT), value :: n diff --git a/gcc/testsuite/gfortran.dg/c-interop/contiguous-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/contiguous-2.f90 index bb8ba20..195ec8c 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/contiguous-2.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/contiguous-2.f90 @@ -1,5 +1,5 @@ ! PR 101304 -! { dg-do run { xfail *-*-* } } +! { dg-do run } ! { dg-additional-sources "contiguous-2-c.c dump-descriptors.c" } ! { dg-additional-options "-g" } ! diff --git a/gcc/testsuite/gfortran.dg/c-interop/contiguous-3.f90 b/gcc/testsuite/gfortran.dg/c-interop/contiguous-3.f90 index 9a6d66b..0a29572 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/contiguous-3.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/contiguous-3.f90 @@ -1,5 +1,5 @@ ! PR 101304 -! { dg-do run { xfail *-*-* } } +! { dg-do run } ! { dg-additional-sources "contiguous-3-c.c dump-descriptors.c" } ! { dg-additional-options "-g" } ! diff --git a/gcc/testsuite/gfortran.dg/c-interop/deferred-character-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/deferred-character-1.f90 index bd6d9cb..3c3c257 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/deferred-character-1.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/deferred-character-1.f90 @@ -16,12 +16,12 @@ module m interface ! These are supposed to be OK - subroutine good1 (x, n) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } } + 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) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } } + subroutine good2 (x, n) bind (c) use iso_c_binding character (kind=C_CHAR, len=:), pointer :: x integer(C_INT), value :: n diff --git a/gcc/testsuite/gfortran.dg/c-interop/deferred-character-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/deferred-character-2.f90 index 9fd046d..356097a 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/deferred-character-2.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/deferred-character-2.f90 @@ -43,7 +43,7 @@ program testit p = 'bar' end subroutine - subroutine frobc (a, p) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } } + subroutine frobc (a, p) bind (c) use iso_c_binding character (kind=C_CHAR, len=:), allocatable :: a character (kind=C_CHAR, len=:), pointer :: p diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-3.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-3.f90 index 174d1e7..c65cb7a 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-3.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-3.f90 @@ -1,5 +1,5 @@ ! PR 101308 -! { dg-do run { xfail *-*-* } } +! { dg-do run } ! { dg-additional-sources "fc-descriptor-3-c.c dump-descriptors.c" } ! { dg-additional-options "-g" } ! diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-5.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-5.f90 index 5ac406f..eda65b4 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-5.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-5.f90 @@ -11,7 +11,7 @@ program testit implicit none interface - subroutine ctest (a) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } } + subroutine ctest (a) bind (c) use iso_c_binding character(len=*,kind=C_CHAR) :: a end subroutine diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-6.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-6.f90 index 8c544d1..1d6d006 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-6.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-6.f90 @@ -1,5 +1,5 @@ ! Reported as pr94070. -! { dg-do run { xfail *-*-* } } +! { dg-do run } ! { dg-additional-sources "fc-descriptor-6-c.c dump-descriptors.c" } ! { dg-additional-options "-g" } ! diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-7-c.c b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-7-c.c index 81d826f..035de03 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-7-c.c +++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-7-c.c @@ -3,14 +3,18 @@ #include <ISO_Fortran_binding.h> #include "dump-descriptors.h" -extern void ctest (CFI_cdesc_t *a); +extern void ctest (CFI_cdesc_t *, _Bool); void -ctest (CFI_cdesc_t *a) +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. */ @@ -33,14 +37,17 @@ ctest (CFI_cdesc_t *a) if (a->dim[1].extent != 10) abort (); - /* There shall be an ordering of the dimensions such that the absolute - value of the sm member of the first dimension is not less than the - elem_len member of the C descriptor and the absolute value of the sm - member of each subsequent dimension is not less than the absolute - value of the sm member of the previous dimension multiplied - by the extent of the previous dimension. */ - if (abs (a->dim[0].sm) < a->elem_len) + if (is_cont != CFI_is_contiguous (a)) abort (); - if (abs (a->dim[1].sm) < abs (a->dim[0].sm) * a->dim[0].extent) + + 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 (); + } } diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-7.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-7.f90 index 5be72e7..40f2e33 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-7.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-7.f90 @@ -1,5 +1,5 @@ ! PR 101309 -! { dg-do run { xfail *-*-* } } +! { dg-do run } ! { dg-additional-sources "fc-descriptor-7-c.c dump-descriptors.c" } ! { dg-additional-options "-g" } ! @@ -8,30 +8,140 @@ program testit use iso_c_binding - implicit none + implicit none (type, external) interface - subroutine ctest (a) bind (c) + subroutine ctest (a, is_cont) bind (c) use iso_c_binding - integer(C_INT), intent (in) :: a(:,:) + 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 argument. - call ctest (transpose (aa)) - call ftest (transpose (aa)) - call ctest (bb(2:10:2, :)) - call ftest (bb(2:10:2, :)) + ! 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) + subroutine ftest (a, is_cont) use iso_c_binding - integer(C_INT), intent(in) :: a(:,:) - call ctest (a) + 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 diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-3.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-3.f90 index c555ada..00a083e 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-3.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-3.f90 @@ -1,5 +1,5 @@ ! PR 101308 -! { dg-do run { xfail *-*-* } } +! { dg-do run } ! { dg-additional-sources "fc-out-descriptor-3-c.c dump-descriptors.c" } ! { dg-additional-options "-g" } ! diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-4.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-4.f90 index b4f6654..a26d495 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-4.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-4.f90 @@ -1,5 +1,5 @@ ! PR 92621 (?) -! { dg-do run { xfail *-*-* } } +! { dg-do run } ! { dg-additional-sources "fc-out-descriptor-4-c.c dump-descriptors.c" } ! { dg-additional-options "-g" } ! diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-5.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-5.f90 index 836683b..63fc08f 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-5.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-5.f90 @@ -10,7 +10,7 @@ program testit implicit none interface - subroutine ctest (a) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } } + subroutine ctest (a) bind (c) use iso_c_binding character(len=*,kind=C_CHAR), intent(out) :: a end subroutine @@ -26,7 +26,7 @@ program testit call ftest (aa) contains - subroutine ftest (a) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } } + subroutine ftest (a) bind (c) use iso_c_binding character(len=*,kind=C_CHAR), intent(out) :: a call ctest (a) diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-6.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-6.f90 index d0c3904..da22615 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-6.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-6.f90 @@ -1,5 +1,5 @@ ! Reported as pr94070. -! { dg-do run { xfail *-*-* } } +! { dg-do run } ! { dg-additional-sources "fc-out-descriptor-6-c.c dump-descriptors.c" } ! { dg-additional-options "-g" } ! diff --git a/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-5.f90 b/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-5.f90 index 2420b7d..e6d17a4 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-5.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-5.f90 @@ -17,7 +17,7 @@ contains ! C binding version - subroutine checkc (a) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } } + subroutine checkc (a) bind (c) use iso_c_binding character(len=*,kind=C_CHAR) :: a @@ -37,7 +37,7 @@ contains end subroutine ! C binding version - subroutine testc (a) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } } + subroutine testc (a) bind (c) use iso_c_binding character(len=*,kind=C_CHAR) :: a diff --git a/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-6.f90 b/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-6.f90 index 8b1167e..090bb15 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-6.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-6.f90 @@ -1,5 +1,5 @@ ! Reported as pr94070. -! { dg-do run { xfail *-*-* } } +! { dg-do run } ! ! This program checks that passing assumed-size arrays to ! and from Fortran functions with C binding works. diff --git a/gcc/testsuite/gfortran.dg/c-interop/shape-bindc.f90 b/gcc/testsuite/gfortran.dg/c-interop/shape-bindc.f90 new file mode 100644 index 0000000..d9e193a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/c-interop/shape-poly.f90 b/gcc/testsuite/gfortran.dg/c-interop/shape-poly.f90 new file mode 100644 index 0000000..e17ca88 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/c-interop/shape.f90 b/gcc/testsuite/gfortran.dg/c-interop/shape.f90 index dd790bb..d05de25 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/shape.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/shape.f90 @@ -15,7 +15,7 @@ ! subroutine with an assumed-rank dummy. program test - + implicit none ! Define some arrays for testing. integer, target :: x1(5) integer :: y1(0:9) @@ -51,7 +51,7 @@ contains r = rank(a) block - integer :: s(r) + integer :: s(r), i s = shape(a) do i = 1, r if (s(i) .ne. size(a,i)) stop 101 diff --git a/gcc/testsuite/gfortran.dg/c-interop/size-bindc.f90 b/gcc/testsuite/gfortran.dg/c-interop/size-bindc.f90 new file mode 100644 index 0000000..132ca50 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/c-interop/size-poly.f90 b/gcc/testsuite/gfortran.dg/c-interop/size-poly.f90 new file mode 100644 index 0000000..2241ab8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-char-c.c b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-char-c.c index c69d224..ca2f49d 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-char-c.c +++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-char-c.c @@ -33,3 +33,9 @@ ctest_1 (CFI_cdesc_t *arg_char, CFI_cdesc_t *arg_ucs4) 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); +} diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-char.f90 b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-char.f90 index ede9fb6..71f84d0 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-char.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-char.f90 @@ -27,11 +27,21 @@ program testit 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 diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-float128.f90 b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-float128.f90 index 907877b..66737b2 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-float128.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-float128.f90 @@ -2,7 +2,7 @@ ! PR 100914 ! PR 100917 ! Fails on x86 targets where sizeof(long double) == 16 (PR100917). -! { dg-do run { xfail { { x86_64*-*-* i?86*-*-* } && longdouble128 } } } +! { 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" } diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-basic.f90 b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-basic.f90 index 5f74468..b586b1f 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-basic.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-basic.f90 @@ -1,7 +1,7 @@ ! PR 101305 ! PR 100917 ! xfailed due to PR 101308 -! { dg-do run { xfail *-*-* } } +! { dg-do run } ! { dg-additional-sources "typecodes-scalar-basic-c.c dump-descriptors.c" } ! { dg-additional-options "-g" } ! diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-float128.f90 b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-float128.f90 index edf9145..c2275c4 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-float128.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-float128.f90 @@ -1,7 +1,7 @@ ! xfailed due to PR 101308 ! PR 101305 ! PR 100914 -! { dg-do run { xfail *-*-* } } +! { 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" } diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-int128.f90 b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-int128.f90 index 5f3c7e1..157c4ca 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-int128.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-int128.f90 @@ -1,6 +1,6 @@ ! PR 101305 ! xfailed due to PR 101308 -! { dg-do run { xfail *-*-* } } +! { 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" } diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-longdouble.f90 b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-longdouble.f90 index c32e012..ddc54f4 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-longdouble.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-longdouble.f90 @@ -1,7 +1,7 @@ ! xfailed due to PR 101308 ! PR 101305 ! PR 100917 -! { dg-do run { xfail *-*-* } } +! { dg-do run } ! { dg-additional-sources "typecodes-scalar-longdouble-c.c dump-descriptors.c" } ! { dg-additional-options "-g" } ! diff --git a/gcc/testsuite/gfortran.dg/c-interop/ubound-bindc.f90 b/gcc/testsuite/gfortran.dg/c-interop/ubound-bindc.f90 new file mode 100644 index 0000000..e771836 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/c-interop/ubound-poly.f90 b/gcc/testsuite/gfortran.dg/c-interop/ubound-poly.f90 new file mode 100644 index 0000000..333a253 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/charlen_04.f90 b/gcc/testsuite/gfortran.dg/charlen_04.f90 index f93465f..97aa0ec 100644 --- a/gcc/testsuite/gfortran.dg/charlen_04.f90 +++ b/gcc/testsuite/gfortran.dg/charlen_04.f90 @@ -3,6 +3,5 @@ program p type t character(*), allocatable :: x(*) ! { dg-error "must have a deferred shape" } - end type + end type ! { dg-error "needs to be a constant specification" "" { target "*-*-*" } .-1 } end -! { dg-excess-errors "needs to be a constant specification" } diff --git a/gcc/testsuite/gfortran.dg/charlen_05.f90 b/gcc/testsuite/gfortran.dg/charlen_05.f90 index 0eb0015..e58f926 100644 --- a/gcc/testsuite/gfortran.dg/charlen_05.f90 +++ b/gcc/testsuite/gfortran.dg/charlen_05.f90 @@ -3,6 +3,5 @@ program p type t character(*) :: x y ! { dg-error "error in data declaration" } - end type + end type ! { dg-error "needs to be a constant specification" "" { target "*-*-*" } .-1 } end -! { dg-excess-errors "needs to be a constant specification" } diff --git a/gcc/testsuite/gfortran.dg/charlen_06.f90 b/gcc/testsuite/gfortran.dg/charlen_06.f90 index e20d604..836c1c69 100644 --- a/gcc/testsuite/gfortran.dg/charlen_06.f90 +++ b/gcc/testsuite/gfortran.dg/charlen_06.f90 @@ -3,6 +3,5 @@ program p type t character(*) :: x+1 ! { dg-error "error in data declaration" } - end type + end type ! { dg-error "needs to be a constant specification" "" { target "*-*-*" } .-1 } end -! { dg-excess-errors "needs to be a constant specification" } diff --git a/gcc/testsuite/gfortran.dg/charlen_13.f90 b/gcc/testsuite/gfortran.dg/charlen_13.f90 index d89b71c..8dc192b 100644 --- a/gcc/testsuite/gfortran.dg/charlen_13.f90 +++ b/gcc/testsuite/gfortran.dg/charlen_13.f90 @@ -4,7 +4,7 @@ program p type t character(2), allocatable :: a(*) ! { dg-error "must have a deferred shape" } character(*), allocatable :: b(2) ! { dg-error "must have a deferred shape" } + ! { dg-error "needs to be a constant specification" "" { target "*-*-*" } .-1 } character(*), allocatable :: c(*) ! { dg-error "must have a deferred shape" } - end type + end type ! { dg-error "needs to be a constant specification" "" { target "*-*-*" } .-1 } end -! { dg-excess-errors "needs to be a constant specification" } diff --git a/gcc/testsuite/gfortran.dg/class_72.f90 b/gcc/testsuite/gfortran.dg/class_72.f90 new file mode 100644 index 0000000..0fd6ec0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_72.f90 @@ -0,0 +1,83 @@ +! PR fortran/102745 + +implicit none + +type t +end type t + +type, extends(t) :: t2 +end type t2 + +type t3 +end type t3 + +type(t), allocatable :: var +type(t2), allocatable :: v2ar +type(t3), allocatable :: v3ar +class(t), allocatable :: cvar +class(t2), allocatable :: c2var +class(t3), allocatable :: c3var + +call f(var) +call f(v2ar) ! { dg-error "passed TYPE.t2. to TYPE.t." } +call f(v2ar%t) +call f(cvar) +call f(c2var) ! { dg-error "passed CLASS.t2. to TYPE.t." } +call f(c2var%t) + +call f2(var) ! { dg-error "passed TYPE.t. to TYPE.t2." } +call f2(v2ar) +call f2(cvar) ! { dg-error "passed CLASS.t. to TYPE.t2." } +call f2(c2var) + + +var = var +var = v2ar ! { dg-error "TYPE.t2. to TYPE.t." } +var = cvar +var = c2var ! { dg-error "TYPE.t2. to TYPE.t." } + +v2ar = var ! { dg-error "Cannot convert TYPE.t. to TYPE.t2." } +v2ar = v2ar +v2ar = cvar ! { dg-error "Cannot convert TYPE.t. to TYPE.t2." } +v2ar = c2var + +cvar = var +cvar = v2ar +cvar = cvar +cvar = c2var + +c2var = var ! { dg-error "Cannot convert TYPE.t. to CLASS.t2." } +c2var = v3ar ! { dg-error "Cannot convert TYPE.t3. to CLASS.t2." } +c2var = v2ar +c2var = cvar ! { dg-error "Cannot convert CLASS.t. to CLASS.t2." } +c2var = c3var ! { dg-error "Cannot convert CLASS.t3. to CLASS.t2." } +c2var = c2var + +allocate (var, source=var) +allocate (var, source=v2ar) ! { dg-error "incompatible with source-expr" } +allocate (var, source=cvar) +allocate (var, source=c2var) ! { dg-error "incompatible with source-expr" } + +allocate (v2ar, source=var) ! { dg-error "incompatible with source-expr" } +allocate (v2ar, source=v2ar) +allocate (v2ar, source=cvar) ! { dg-error "incompatible with source-expr" } +allocate (v2ar, source=c2var) + +allocate (cvar, source=var) +allocate (cvar, source=v2ar) +allocate (cvar, source=cvar) +allocate (cvar, source=c2var) + +allocate (c2var, source=var) ! { dg-error "incompatible with source-expr" } +allocate (c2var, source=v2ar) +allocate (c2var, source=cvar) ! { dg-error "incompatible with source-expr" } +allocate (c2var, source=c2var) + +contains + subroutine f(x) + type(t) :: x + end + subroutine f2(x) + type(t2) :: x + end +end diff --git a/gcc/testsuite/gfortran.dg/coarray_9.f90 b/gcc/testsuite/gfortran.dg/coarray_9.f90 index 0a4dbec..b613428 100644 --- a/gcc/testsuite/gfortran.dg/coarray_9.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_9.f90 @@ -16,4 +16,4 @@ critical ! "Coarrays disabled" (but error above is fatal) end critical ! "Expecting END PROGRAM statement" (but error above is fatal) end -! { dg-excess-errors "compilation terminated" } +! { dg-prune-output "compilation terminated" } diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_3.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_3.f90 index 2a3ddf4..04d540f 100644 --- a/gcc/testsuite/gfortran.dg/coarray_collectives_3.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_3.f90 @@ -8,4 +8,4 @@ program test integer :: val call co_max(val) ! { dg-error "Coarrays disabled at .1., use '-fcoarray=' to enable" } end program test -! { dg-excess-errors "compilation terminated" } +! { dg-prune-output "compilation terminated" } diff --git a/gcc/testsuite/gfortran.dg/data_invalid.f90 b/gcc/testsuite/gfortran.dg/data_invalid.f90 index 960a8f3..6d03587 100644 --- a/gcc/testsuite/gfortran.dg/data_invalid.f90 +++ b/gcc/testsuite/gfortran.dg/data_invalid.f90 @@ -40,7 +40,7 @@ SUBROUTINE data_init_array_invalid() data e(2) / 2 / ! { dg-error "re-initialization" } integer :: f(3) = 0 ! { dg-error "already is initialized" } - data f(2) / 1 / + data f(2) / 1 / ! { dg-error "already is initialized" } ! full array initializer, re-initialize subsection integer :: g(3) @@ -48,7 +48,7 @@ SUBROUTINE data_init_array_invalid() data g(1:2) / 2*2 / ! { dg-error "re-initialization" } integer :: h(3) = 1 ! { dg-error "already is initialized" } - data h(2:3) / 2*2 / + data h(2:3) / 2*2 / ! { dg-error "already is initialized" } ! full array initializer, re-initialize full array integer :: i(3) @@ -56,7 +56,7 @@ SUBROUTINE data_init_array_invalid() data i / 2,2,2 / ! { dg-error "re-initialization" } integer :: j(3) = 1 ! { dg-error "already is initialized" } - data j / 3*2 / + data j / 3*2 / ! { dg-error "already is initialized" } END SUBROUTINE SUBROUTINE data_init_matrix_invalid() @@ -85,7 +85,7 @@ SUBROUTINE data_init_matrix_invalid() data e(2,3) / 2 / ! { dg-error "re-initialization" } integer :: f(3,3) = 1 ! { dg-error "already is initialized" } - data f(3,2) / 2 / + data f(3,2) / 2 / ! { dg-error "already is initialized" } ! full array initializer, re-initialize subsection integer :: g(3,3) @@ -93,7 +93,7 @@ SUBROUTINE data_init_matrix_invalid() data g(2:3,2:3) / 2, 2*3, 4 / ! { dg-error "re-initialization" } integer :: h(3,3) = 1 ! { dg-error "already is initialized" } - data h(2:3,2:3) / 2, 2*3, 4 / + data h(2:3,2:3) / 2, 2*3, 4 / ! { dg-error "already is initialized" } ! full array initializer, re-initialize full array integer :: i(3,3) @@ -101,7 +101,7 @@ SUBROUTINE data_init_matrix_invalid() data i / 9 * 1 / ! { dg-error "re-initialization" } integer :: j(3,3) = 0 ! { dg-error "already is initialized" } - data j / 9 * 1 / + data j / 9 * 1 / ! { dg-error "already is initialized" } END SUBROUTINE SUBROUTINE data_init_misc_invalid() @@ -112,11 +112,9 @@ SUBROUTINE data_init_misc_invalid() ! index out-of-bounds, direct access integer :: b(3) data b(-2) / 1 / ! { dg-error "below array lower bound" } - + ! { dg-warning "is out of bounds" "" { target *-*-* } .-1 } ! index out-of-bounds, implied do-loop (PR32315) integer :: i character(len=20), dimension(4) :: string data (string(i), i = 1, 5) / 'A', 'B', 'C', 'D', 'E' / ! { dg-error "above array upper bound" } END SUBROUTINE - -! { dg-excess-errors "" } diff --git a/gcc/testsuite/gfortran.dg/derived_constructor_char_1.f90 b/gcc/testsuite/gfortran.dg/derived_constructor_char_1.f90 index 892a9c9..91fc4c9 100644 --- a/gcc/testsuite/gfortran.dg/derived_constructor_char_1.f90 +++ b/gcc/testsuite/gfortran.dg/derived_constructor_char_1.f90 @@ -5,7 +5,7 @@ ! ! Type :: t5 - character (len=5) :: txt(4) + character (len=5) :: txt(2) End Type t5 character (len=3), parameter :: str3(2) = [ "ABC", "ZYX" ] diff --git a/gcc/testsuite/gfortran.dg/do_4.f b/gcc/testsuite/gfortran.dg/do_4.f index 6d688a0..e391b68 100644 --- a/gcc/testsuite/gfortran.dg/do_4.f +++ b/gcc/testsuite/gfortran.dg/do_4.f @@ -4,6 +4,7 @@ if(i.eq.5)then goto 10 10 endif ! { dg-error "is within another block" } - end -! { dg-excess-errors "" } + end ! { dg-error "END DO statement expected" } + ! { dg-warning "Fortran 2018 deleted feature: DO termination statement which is not END DO or CONTINUE" "" { target "*-*-*" } 6 } +! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } diff --git a/gcc/testsuite/gfortran.dg/dollar_sym_1.f90 b/gcc/testsuite/gfortran.dg/dollar_sym_1.f90 index cb53fd3..5cee775 100644 --- a/gcc/testsuite/gfortran.dg/dollar_sym_1.f90 +++ b/gcc/testsuite/gfortran.dg/dollar_sym_1.f90 @@ -7,4 +7,4 @@ PARAMETER (PLT$B_OPC=0) ! Unreachable as the error above is now fatal common /abc$def/ PLT$C_HOUSTPIX, PLT$C_COMMAND ! Unreachable as the error above is now fatal end -! { dg-excess-errors "compilation terminated" } +! { dg-prune-output "compilation terminated" } diff --git a/gcc/testsuite/gfortran.dg/dollar_sym_3.f b/gcc/testsuite/gfortran.dg/dollar_sym_3.f index 7b9b344..52ce041 100644 --- a/gcc/testsuite/gfortran.dg/dollar_sym_3.f +++ b/gcc/testsuite/gfortran.dg/dollar_sym_3.f @@ -8,4 +8,4 @@ c Segmentation fault in gfc_restore_last_undo_checkpoint COMMON RADE3155V62$JUTMU9L9E(3,3,3), LADE314JUTMP9 ! { dg-error "Invalid character '\\$' at .1.. Use '-fdollar-ok' to allow it as an extension" } +LHEDDJNTMP9L(3,3,3) end -! { dg-excess-errors "compilation terminated" } +! { dg-prune-output "compilation terminated" } diff --git a/gcc/testsuite/gfortran.dg/fmt_tab_1.f90 b/gcc/testsuite/gfortran.dg/fmt_tab_1.f90 index a763714..0b36aee 100644 --- a/gcc/testsuite/gfortran.dg/fmt_tab_1.f90 +++ b/gcc/testsuite/gfortran.dg/fmt_tab_1.f90 @@ -6,7 +6,6 @@ write (*, 10) ! There is a tab character before 'bug!'. This is accepted without ! the -Wno-tabs option or a -std= option. - 10 format ('Hello ', 'bug!') ! { dg-warning "tab character in format" } - + 10 format ('Hello ', 'bug!') ! { dg-warning "tab character in format at " } + ! { dg-warning "tab character at " "" { target "*-*-*" } .-1 } end -! { dg-excess-errors "tab character in format" } diff --git a/gcc/testsuite/gfortran.dg/fmt_tab_2.f90 b/gcc/testsuite/gfortran.dg/fmt_tab_2.f90 index bfff7ce..3f2d6fc 100644 --- a/gcc/testsuite/gfortran.dg/fmt_tab_2.f90 +++ b/gcc/testsuite/gfortran.dg/fmt_tab_2.f90 @@ -5,5 +5,4 @@ program TestFormat write (*, 10) 10 format ('Hello ', 'bug!') ! { dg-warning "tab character in format" } - end -! { dg-excess-errors "tab character in FORMAT" } + end ! { dg-warning "tab character at " "" { target "*-*-*" } .-1 } diff --git a/gcc/testsuite/gfortran.dg/forall_16.f90 b/gcc/testsuite/gfortran.dg/forall_16.f90 index 017aa5a..e341c37 100644 --- a/gcc/testsuite/gfortran.dg/forall_16.f90 +++ b/gcc/testsuite/gfortran.dg/forall_16.f90 @@ -4,6 +4,4 @@ implicit none integer i,dest(10) forall (i=2:ix) dest(i)=i ! { dg-error "has no IMPLICIT type" } -end - -! { dg-excess-errors "Can't convert UNKNOWN to INTEGER" } +end ! { dg-error "Cannot convert UNKNOWN to INTEGER" "" { target "*-*-*" } .-1 } diff --git a/gcc/testsuite/gfortran.dg/g77/970125-0.f b/gcc/testsuite/gfortran.dg/g77/970125-0.f index 656c475..0c12e26 100644 --- a/gcc/testsuite/gfortran.dg/g77/970125-0.f +++ b/gcc/testsuite/gfortran.dg/g77/970125-0.f @@ -1,7 +1,6 @@ c { dg-do compile } c -c Following line added on transfer to gfortran testsuite -c { dg-excess-errors "" } +c { dg-additional-options "-w" } c C JCB comments: C g77 doesn't accept the added line "integer(kind=7) ..." -- @@ -35,10 +34,10 @@ c Frontend bug fixed by JCB 1998-06-01 com.c &c changes. print *, max4 print *, i4, %loc(i4) print *, i8, %loc(i8) - call foo(i4, %loc(i4), 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 + integer(kind=7) i4a, i8a ! { dg-error "Kind 7 not supported for type INTEGER" } integer(kind=8) i8 print *, i4, i4a print *, i8, i8a diff --git a/gcc/testsuite/gfortran.dg/gomp/cancel-1.f90 b/gcc/testsuite/gfortran.dg/gomp/cancel-1.f90 index d60dd72..1bfddc7 100644 --- a/gcc/testsuite/gfortran.dg/gomp/cancel-1.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/cancel-1.f90 @@ -265,6 +265,7 @@ subroutine f2 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" } @@ -417,6 +418,7 @@ subroutine f2 !$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" } @@ -515,6 +517,7 @@ subroutine f3 end do !$omp end do nowait !$omp sections + !$omp section block !$omp cancel sections ! { dg-warning "nowait" } end block diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-1.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-1.f90 new file mode 100644 index 0000000..de09dbf --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-10.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-10.f90 new file mode 100644 index 0000000..d6d2c8c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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-*-* } && lp64 } } } } + ! { dg-final { scan-tree-dump-times "f04 \\\(\\\);" 1 "gimple" { target { { ! lp64 } || { ! { 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 + diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-11.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-11.f90 new file mode 100644 index 0000000..60aa0fc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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-*-* } && lp64 } } } } + ! { dg-final { scan-tree-dump-times "f24 \\\(\\\);" 1 "gimple" { target { { i?86-*-* x86_64-*-* } && { ! lp64 } } } } } + ! { 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 diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-12.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-12.f90 new file mode 100644 index 0000000..610693e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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-*-* } && lp64 } } } } + ! { dg-final { scan-tree-dump-times "f11 \\\(\\\);" 1 "gimple" { target { { i?86-*-* x86_64-*-* } && { ! lp64 } } } } } + ! { 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 + diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-13.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-13.f90 new file mode 100644 index 0000000..91648f9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-14.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-14.f90 new file mode 100644 index 0000000..06c9a5d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-15.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-15.f90 new file mode 100644 index 0000000..4a88e3e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-16.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-16.f90 new file mode 100644 index 0000000..5e34d47 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-17.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-17.f90 new file mode 100644 index 0000000..df57f9c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-18.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-18.f90 new file mode 100644 index 0000000..f97cf34 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-19.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-19.f90 new file mode 100644 index 0000000..d387f5e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90 new file mode 100644 index 0000000..63d7778 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-2a.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-2a.f90 new file mode 100644 index 0000000..56de117 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-3.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-3.f90 new file mode 100644 index 0000000..c62622b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-4.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-4.f90 new file mode 100644 index 0000000..bc4f416 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-5.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-5.f90 new file mode 100644 index 0000000..ad7acb9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-6.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-6.f90 new file mode 100644 index 0000000..3f33f38 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-7.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-7.f90 new file mode 100644 index 0000000..1590a2a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-8.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-8.f90 new file mode 100644 index 0000000..c751489 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-9.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-9.f90 new file mode 100644 index 0000000..ebd0666 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/gomp/nesting-3.f90 b/gcc/testsuite/gfortran.dg/gomp/nesting-3.f90 index cd2e39a..5d0d200 100644 --- a/gcc/testsuite/gfortran.dg/gomp/nesting-3.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/nesting-3.f90 @@ -7,7 +7,7 @@ subroutine f1 block; end block end do !$omp sections ! { dg-error "may not be closely nested" } - block; end block + call do_work !$omp section block; end block !$omp end sections @@ -33,7 +33,7 @@ subroutine f1 !$omp end sections !$omp sections !$omp sections ! { dg-error "may not be closely nested" } - block; end block + call do_work !$omp section block; end block !$omp end sections @@ -72,7 +72,7 @@ subroutine f1 !$omp sections !$omp section !$omp sections ! { dg-error "may not be closely nested" } - block; end block + call do_work !$omp section block; end block !$omp end sections @@ -105,7 +105,7 @@ subroutine f1 block; end block end do !$omp sections ! { dg-error "may not be closely nested" } - block; end block + call do_work !$omp section block; end block !$omp end sections @@ -129,7 +129,7 @@ subroutine f1 block; end block end do !$omp sections ! { dg-error "may not be closely nested" } - block; end block + call do_work !$omp section block; end block !$omp end sections @@ -150,7 +150,7 @@ subroutine f1 block; end block end do !$omp sections ! { dg-error "may not be closely nested" } - block; end block + call do_work !$omp section block; end block !$omp end sections @@ -171,7 +171,7 @@ subroutine f1 block; end block end do !$omp sections ! { dg-error "may not be closely nested" } - block; end block + call do_work !$omp section block; end block !$omp end sections @@ -195,7 +195,7 @@ subroutine f1 block; end block end do !$omp sections - block; end block + call do_work !$omp section block; end block !$omp end sections @@ -224,7 +224,7 @@ subroutine f1 block; end block end do !$omp sections - block; end block + call do_work !$omp section block; end block !$omp end sections @@ -257,7 +257,7 @@ subroutine f2 block; end block end do !$omp sections ! { dg-error "may not be closely nested" } - block; end block + call do_work !$omp section block; end block !$omp end sections diff --git a/gcc/testsuite/gfortran.dg/gomp/reduction4.f90 b/gcc/testsuite/gfortran.dg/gomp/reduction4.f90 index 52d504b..71b4231 100644 --- a/gcc/testsuite/gfortran.dg/gomp/reduction4.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/reduction4.f90 @@ -137,7 +137,7 @@ end ! { 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 in_reduction\\(\\\+:b\\)" 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" } } diff --git a/gcc/testsuite/gfortran.dg/gomp/strictly-structured-block-1.f90 b/gcc/testsuite/gfortran.dg/gomp/strictly-structured-block-1.f90 new file mode 100644 index 0000000..ef8507e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/gomp/strictly-structured-block-2.f90 b/gcc/testsuite/gfortran.dg/gomp/strictly-structured-block-2.f90 new file mode 100644 index 0000000..ad4d08a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/gomp/strictly-structured-block-3.f90 b/gcc/testsuite/gfortran.dg/gomp/strictly-structured-block-3.f90 new file mode 100644 index 0000000..ae85fa0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/gomp/unexpected-end.f90 b/gcc/testsuite/gfortran.dg/gomp/unexpected-end.f90 index d2e8daa..96f10b5 100644 --- a/gcc/testsuite/gfortran.dg/gomp/unexpected-end.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/unexpected-end.f90 @@ -120,4 +120,4 @@ end do end ! { dg-error "Unexpected END statement" } -! { dg-excess-errors "Unexpected end of file" } +! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } diff --git a/gcc/testsuite/gfortran.dg/interface_operator_1.f90 b/gcc/testsuite/gfortran.dg/interface_operator_1.f90 index 97d260a..6684751 100644 --- a/gcc/testsuite/gfortran.dg/interface_operator_1.f90 +++ b/gcc/testsuite/gfortran.dg/interface_operator_1.f90 @@ -7,4 +7,4 @@ program p interface operator ( .gt. ) end interface operator ! { dg-error "END INTERFACE OPERATOR" } end program p ! { dg-error "END INTERFACE" } -! { dg-excess-errors "Unexpected end of file" } +! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } diff --git a/gcc/testsuite/gfortran.dg/interface_operator_2.f90 b/gcc/testsuite/gfortran.dg/interface_operator_2.f90 index a739596..11b9ff5 100644 --- a/gcc/testsuite/gfortran.dg/interface_operator_2.f90 +++ b/gcc/testsuite/gfortran.dg/interface_operator_2.f90 @@ -7,4 +7,4 @@ program p interface operator ( .gt. ) end interface operator (.lt.) ! { dg-error "END INTERFACE OPERATOR" } end program p ! { dg-error "END INTERFACE" } -! { dg-excess-errors "Unexpected end of file" } +! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } diff --git a/gcc/testsuite/gfortran.dg/interface_operator_3.f90 b/gcc/testsuite/gfortran.dg/interface_operator_3.f90 new file mode 100644 index 0000000..6a580b2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/interface_operator_3.f90 @@ -0,0 +1,141 @@ +! { dg-do compile } +! PR fortran/65454 - accept both old and new-style relational operators + +module m + implicit none + private :: t1 + type t1 + integer :: i + end type t1 + interface operator (==) + module procedure :: my_cmp + end interface + interface operator (/=) + module procedure :: my_cmp + end interface + interface operator (<=) + module procedure :: my_cmp + end interface + interface operator (<) + module procedure :: my_cmp + end interface + interface operator (>=) + module procedure :: my_cmp + end interface + interface operator (>) + module procedure :: my_cmp + end interface +contains + elemental function my_cmp (a, b) result (c) + type(t1), intent(in) :: a, b + logical :: c + c = a%i == b%i + end function my_cmp +end module m + +module m_os + implicit none + private :: t2 + type t2 + integer :: i + end type t2 + interface operator (.eq.) + module procedure :: my_cmp + end interface + interface operator (.ne.) + module procedure :: my_cmp + end interface + interface operator (.le.) + module procedure :: my_cmp + end interface + interface operator (.lt.) + module procedure :: my_cmp + end interface + interface operator (.ge.) + module procedure :: my_cmp + end interface + interface operator (.gt.) + module procedure :: my_cmp + end interface +contains + elemental function my_cmp (a, b) result (c) + type(t2), intent(in) :: a, b + logical :: c + c = a%i .eq. b%i + end function my_cmp +end module m_os + +! new style only +module m1 + use m, only: operator(==), operator(/=) + use m, only: operator(<=), operator(<) + use m, only: operator(>=), operator(>) +end module m1 + +! old -> new style +module m2 + use m_os, only: operator(==), operator(/=) + use m_os, only: operator(<=), operator(<) + use m_os, only: operator(>=), operator(>) +end module m2 + +! new -> old style +module m3 + use m, only: operator(.eq.), operator(.ne.) + use m, only: operator(.le.), operator(.lt.) + use m, only: operator(.ge.), operator(.gt.) +end module m3 + +! old style only +module m4 + use m_os, only: operator(.eq.), operator(.ne.) + use m_os, only: operator(.le.), operator(.lt.) + use m_os, only: operator(.ge.), operator(.gt.) +end module m4 + +! new -> all styles +module m5 + use m, only: operator(.eq.), operator(.ne.), operator(==), operator(/=) + use m, only: operator(.le.), operator(.lt.), operator(<=), operator(<) + use m, only: operator(.ge.), operator(.gt.), operator(>=), operator(>) +end module m5 + +! old -> all styles +module m6 + use m_os, only: operator(.eq.), operator(.ne.), operator(==), operator(/=) + use m_os, only: operator(.le.), operator(.lt.), operator(<=), operator(<) + use m_os, only: operator(.ge.), operator(.gt.), operator(>=), operator(>) +end module m6 + +! all -> all styles +module m7 + use m, only: operator(.eq.), operator(.ne.), operator(==), operator(/=) + use m, only: operator(.le.), operator(.lt.), operator(<=), operator(<) + use m, only: operator(.ge.), operator(.gt.), operator(>=), operator(>) + use m_os, only: operator(.eq.), operator(.ne.), operator(==), operator(/=) + use m_os, only: operator(.le.), operator(.lt.), operator(<=), operator(<) + use m_os, only: operator(.ge.), operator(.gt.), operator(>=), operator(>) +end module m7 + +module m_eq + implicit none + private :: t3 + type t3 + integer :: i + end type t3 + interface operator (==) + module procedure :: my_cmp + end interface +contains + elemental function my_cmp (a, b) result (c) + type(t3), intent(in) :: a, b + logical :: c + c = a%i == b%i + end function my_cmp +end module m_eq + +module m8 + use m_eq, only: operator(==), operator(.eq.) + use m_eq, only: operator(/=) ! { dg-error "operator ./=. referenced" } + use m_eq, only: operator(.ne.) ! { dg-error "operator .\.ne\.. referenced" } +end module m8 diff --git a/gcc/testsuite/gfortran.dg/iso_c_binding_char_1.f90 b/gcc/testsuite/gfortran.dg/iso_c_binding_char_1.f90 index a261656..2a4a618 100644 --- a/gcc/testsuite/gfortran.dg/iso_c_binding_char_1.f90 +++ b/gcc/testsuite/gfortran.dg/iso_c_binding_char_1.f90 @@ -4,8 +4,7 @@ ! ! Contributed by Thomas Koenig <tkoenig@gcc.gnu.org> ! -subroutine bar(c,d) BIND(C) ! { dg-error "character dummy argument 'c' at .1. with assumed length is not yet supported for procedure 'bar' with BIND\\(C\\) attribute" } - ! { dg-error "Character dummy argument 'd' at .1. must be of constant length of one or assumed length, unless it has assumed shape or assumed rank, as procedure 'bar' has the BIND\\(C\\) attribute" "" { target *-*-* } .-1 } +subroutine bar(c,d) BIND(C) ! { dg-error "Character dummy argument 'd' at .1. must be of constant length of one or assumed length, unless it has assumed shape or assumed rank, as procedure 'bar' has the BIND\\(C\\) attribute" } character (len=*) c character (len=2) d end diff --git a/gcc/testsuite/gfortran.dg/line_length_4.f90 b/gcc/testsuite/gfortran.dg/line_length_4.f90 index 6e3c76e..8004040 100644 --- a/gcc/testsuite/gfortran.dg/line_length_4.f90 +++ b/gcc/testsuite/gfortran.dg/line_length_4.f90 @@ -16,4 +16,4 @@ end subroutine foo end ! { dg-error "Line truncated" " " { target *-*-* } 8 } -! { dg-excess-errors "some warnings being treated as errors" } +! { dg-prune-output "some warnings being treated as errors" } diff --git a/gcc/testsuite/gfortran.dg/line_length_5.f90 b/gcc/testsuite/gfortran.dg/line_length_5.f90 index d7aca12..8183245 100644 --- a/gcc/testsuite/gfortran.dg/line_length_5.f90 +++ b/gcc/testsuite/gfortran.dg/line_length_5.f90 @@ -4,4 +4,4 @@ print *, 'aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa end ! { dg-error "Line truncated" " " { target *-*-* } 3 } ! { dg-error "Unterminated character constant" " " { target *-*-* } 3 } -! { dg-excess-errors "some warnings being treated as errors" } +! { dg-prune-output "some warnings being treated as errors" } diff --git a/gcc/testsuite/gfortran.dg/line_length_6.f90 b/gcc/testsuite/gfortran.dg/line_length_6.f90 index 92f3401..8cdb0209 100644 --- a/gcc/testsuite/gfortran.dg/line_length_6.f90 +++ b/gcc/testsuite/gfortran.dg/line_length_6.f90 @@ -5,4 +5,4 @@ ! print *, 1 + 2 ! { dg-error "Line truncated at .1." } end -! { dg-excess-errors "some warnings being treated as errors" } +! { dg-prune-output "some warnings being treated as errors" } diff --git a/gcc/testsuite/gfortran.dg/line_length_8.f90 b/gcc/testsuite/gfortran.dg/line_length_8.f90 index 3f0efaf..afd6cc2 100644 --- a/gcc/testsuite/gfortran.dg/line_length_8.f90 +++ b/gcc/testsuite/gfortran.dg/line_length_8.f90 @@ -6,4 +6,4 @@ ! print *, 1 + 2 ! { dg-error "Line truncated at .1." } end -! { dg-excess-errors "some warnings being treated as errors" } +! { dg-prune-output "some warnings being treated as errors" } diff --git a/gcc/testsuite/gfortran.dg/line_length_9.f90 b/gcc/testsuite/gfortran.dg/line_length_9.f90 index f338972..6c156af 100644 --- a/gcc/testsuite/gfortran.dg/line_length_9.f90 +++ b/gcc/testsuite/gfortran.dg/line_length_9.f90 @@ -6,4 +6,4 @@ ! print *, 1 + 2 ! { dg-error "Line truncated at .1." } end -! { dg-excess-errors "some warnings being treated as errors" } +! { dg-prune-output "some warnings being treated as errors" } diff --git a/gcc/testsuite/gfortran.dg/lto/bind-c-char_0.f90 b/gcc/testsuite/gfortran.dg/lto/bind-c-char_0.f90 new file mode 100644 index 0000000..48b495b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/parameter_array_init_8.f90 b/gcc/testsuite/gfortran.dg/parameter_array_init_8.f90 new file mode 100644 index 0000000..2e5f769 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/parameter_array_init_8.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! PR fortran/99348 +! PR fortran/102521 +! Check simplifications for initialization of DT parameter arrays + +program p + type t + integer :: n + end type + type(t), parameter :: a(4) = t(1) + type(t), parameter :: d(*) = a + type(t), parameter :: b(2,2) = reshape(d, [2,2]) + integer, parameter :: nn = b(2,2)% n + type u + character(3) :: c + end type + type(u), parameter :: x(2,3) = u('ab') + type(u), parameter :: y(*,*) = transpose (x) + character(*), parameter :: c = y(3,2)% c + integer, parameter :: lc = c% len + integer, parameter :: lyc = len (y(3,2)% c) +! integer, parameter :: lxc = x(1,1)% c% len ! fails (pr101735?) + if (nn /= 1) stop 1 + if (lc /= 3 .or. lyc /= 3 .or. c /= "ab ") stop 2 +end diff --git a/gcc/testsuite/gfortran.dg/pdt_32.f03 b/gcc/testsuite/gfortran.dg/pdt_32.f03 new file mode 100644 index 0000000..f8d4041 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_32.f03 @@ -0,0 +1,17 @@ +! { dg-do compile } +! PR fortran/102956 +! PDT KIND and LEN type parameters are mutually exclusive (F2018:R734) +! +module m + type :: good_pdt (k,l) + integer, kind :: k = 1 + integer, len :: l = 1 + character(kind=k,len=l) :: c + end type good_pdt + + type :: bad_pdt (k,l) ! { dg-error "does not have a component" } + integer, kind, len :: k = 1 ! { dg-error "attribute conflicts with" } + integer, len, kind :: l = 1 ! { dg-error "attribute conflicts with" } + character(kind=k,len=l) :: c ! { dg-error "has not been declared" } + end type bad_pdt +end diff --git a/gcc/testsuite/gfortran.dg/pdt_4.f03 b/gcc/testsuite/gfortran.dg/pdt_4.f03 index c1af65a..37412e4 100644 --- a/gcc/testsuite/gfortran.dg/pdt_4.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_4.f03 @@ -28,9 +28,9 @@ end module type :: bad_pdt (a,b, c, d) ! { dg-error "does not have a component" } real, kind :: a ! { dg-error "must be INTEGER" } - INTEGER(8), kind :: b ! { dg-error "be default integer kind" } + INTEGER(8), kind :: b real, LEN :: c ! { dg-error "must be INTEGER" } - INTEGER(8), LEN :: d ! { dg-error "be default integer kind" } + INTEGER(8), LEN :: d end type type :: mytype (a,b) diff --git a/gcc/testsuite/gfortran.dg/pr102685.f90 b/gcc/testsuite/gfortran.dg/pr102685.f90 new file mode 100644 index 0000000..d325c27 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr102685.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! PR fortran/102685 + +program p + type t + integer :: a(2) + end type + type(t), parameter :: x0 = t([2]) ! { dg-error "shape of component" } + type(t), parameter :: x1(2) = t([2]) ! { dg-error "shape of component" } + type(t), parameter :: x(2) = t([integer::]) ! { dg-error "shape of component" } + + type u + integer :: a + integer :: b(0) + end type + type(u), parameter :: z0(2) = u(1, [integer::]) ! valid + type(u), parameter :: z1 = u(1, 2 ) ! valid + type(u), parameter :: z2(2) = u(1, 2 ) ! valid + type(u), parameter :: z3 = u(1, [2]) ! { dg-error "shape of component" } + type(u), parameter :: z4(2) = u(1, [2]) ! { dg-error "shape of component" } + + type v + integer :: a(2,1) + end type + type(v), parameter :: y0 = v(reshape([1,2],[2,1])) ! valid + type(v), parameter :: y1 = v(reshape([1,2],[1,2])) ! { dg-error "shape of component" } + type(v), parameter :: y(1) = v(reshape([1,2],[1,2])) ! { dg-error "shape of component" } + + print *, x0,x,x1,y0,y1,y,z0,z1,z2,z3,z4 +end diff --git a/gcc/testsuite/gfortran.dg/pr102816.f90 b/gcc/testsuite/gfortran.dg/pr102816.f90 new file mode 100644 index 0000000..4683174 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr102816.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/102816 + +program p + type t + integer :: a([2]) ! { dg-error "must be scalar" } + end type + type(t) :: x = t([3, 4]) ! { dg-error "Bad array spec of component" } +end diff --git a/gcc/testsuite/gfortran.dg/pr65045.f90 b/gcc/testsuite/gfortran.dg/pr65045.f90 index 5b838d5..c496529 100644 --- a/gcc/testsuite/gfortran.dg/pr65045.f90 +++ b/gcc/testsuite/gfortran.dg/pr65045.f90 @@ -12,4 +12,4 @@ i:block end block i ! { dg-error "Expecting END PROGRAM statement" } print*,i ! { dg-error "not appropriate for an expression" } end -! { dg-excess-errors "Unexpected end of file" } +! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } diff --git a/gcc/testsuite/gfortran.dg/pr69497.f90 b/gcc/testsuite/gfortran.dg/pr69497.f90 index 1698ebb..291d906 100644 --- a/gcc/testsuite/gfortran.dg/pr69497.f90 +++ b/gcc/testsuite/gfortran.dg/pr69497.f90 @@ -5,4 +5,4 @@ program p do end block ! { dg-error "Expecting END DO statement" } end ! { dg-error "END DO statement expected" } -! { dg-excess-errors "Unexpected end of file" } +! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } diff --git a/gcc/testsuite/gfortran.dg/pr70931.f90 b/gcc/testsuite/gfortran.dg/pr70931.f90 index 08ecd68..4444b5e 100644 --- a/gcc/testsuite/gfortran.dg/pr70931.f90 +++ b/gcc/testsuite/gfortran.dg/pr70931.f90 @@ -5,6 +5,7 @@ program p integer :: a integer :: b(0) end type - type(t), parameter :: z = t(1, [2]) +! type(t), parameter :: z = t(1, [2]) ! original invalid code + type(t), parameter :: z = t(1, [integer::]) print *, z end diff --git a/gcc/testsuite/gfortran.dg/pr86551.f90 b/gcc/testsuite/gfortran.dg/pr86551.f90 new file mode 100644 index 0000000..d96e17a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr86551.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! PR fortran/86551 - ICE on invalid code with select type / end select type + +subroutine b + type :: t1 + end type t1 + class(t1) :: c2 + select type (d => c2) + end select type ! { dg-error "Syntax error" } +end ! { dg-error "END SELECT statement expected" } + +! { dg-prune-output "Unexpected end of file" } diff --git a/gcc/testsuite/gfortran.dg/pr93792.f90 b/gcc/testsuite/gfortran.dg/pr93792.f90 index 960d050..c7939af 100644 --- a/gcc/testsuite/gfortran.dg/pr93792.f90 +++ b/gcc/testsuite/gfortran.dg/pr93792.f90 @@ -14,4 +14,4 @@ end ! { dg-error "Parameterized type 't' does not have a component" " " { target *-*-* } 5 } ! { dg-error "BOZ literal constant at .1. cannot appear" " " { target *-*-* } 6 } ! { dg-error "Cannot open module file" " " { target *-*-* } 10 } -! { dg-excess-errors "compilation terminated" } +! { dg-prune-output "compilation terminated" } diff --git a/gcc/testsuite/gfortran.dg/reshape_shape_2.f90 b/gcc/testsuite/gfortran.dg/reshape_shape_2.f90 new file mode 100644 index 0000000..8f17576 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/reshape_shape_2.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/102717 + +program p + integer, parameter :: a(1) = 2 + integer, parameter :: b(2) = reshape([3,4], -[a]) ! { dg-error "negative" } +end diff --git a/gcc/testsuite/gfortran.dg/shape_10.f90 b/gcc/testsuite/gfortran.dg/shape_10.f90 new file mode 100644 index 0000000..4943c21 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/shape_10.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR fortran/102716 + +program p + integer, parameter :: a(1) = shape([2], [1]) ! { dg-error "must be a scalar" } +end diff --git a/gcc/testsuite/gfortran.dg/submodule_21.f08 b/gcc/testsuite/gfortran.dg/submodule_21.f08 index c96acb2..bb62600 100644 --- a/gcc/testsuite/gfortran.dg/submodule_21.f08 +++ b/gcc/testsuite/gfortran.dg/submodule_21.f08 @@ -16,4 +16,5 @@ PROGRAM MyProg USE MainModule WRITE(*,*) a END PROGRAM MyProg -! { dg-excess-errors "does not contain a MODULE PROCEDURE" } +! { dg-error "does not contain a MODULE PROCEDURE" "" { target "*-*-*" } 0 } +! { dg-prune-output "compilation terminated" } diff --git a/gcc/testsuite/gfortran.dg/tab_continuation.f b/gcc/testsuite/gfortran.dg/tab_continuation.f index 85d2307..719b03f 100644 --- a/gcc/testsuite/gfortran.dg/tab_continuation.f +++ b/gcc/testsuite/gfortran.dg/tab_continuation.f @@ -17,4 +17,4 @@ ! { dg-error "Nonconforming tab character in column 1 of line 13" "Nonconforming tab" { target *-*-* } 0 } ! { dg-error "Nonconforming tab character in column 1 of line 14" "Nonconforming tab" { target *-*-* } 0 } ! { dg-error "Nonconforming tab character in column 1 of line 15" "Nonconforming tab" { target *-*-* } 0 } -! { dg-excess-errors "some warnings being treated as errors" } +! { dg-prune-output "some warnings being treated as errors" } diff --git a/gcc/testsuite/gfortran.dg/transfer_simplify_2.f90 b/gcc/testsuite/gfortran.dg/transfer_simplify_2.f90 index e0f3f94..b428fa6 100644 --- a/gcc/testsuite/gfortran.dg/transfer_simplify_2.f90 +++ b/gcc/testsuite/gfortran.dg/transfer_simplify_2.f90 @@ -145,7 +145,7 @@ contains real(4) :: x(2) end type mytype - type (mytype), parameter :: dt1(2) = transfer (c1, mytype ((/1.0,2.0,3.0,4.0/)), 2) + type (mytype), parameter :: dt1(2) = transfer (c1, mytype ((/1.0,2.0/)), 2) type (mytype) :: dt2(2) dt2 = transfer (c2, dt2); diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_2.f90 b/gcc/testsuite/gfortran.dg/typebound_proc_2.f90 index a34d935..14f01ef 100644 --- a/gcc/testsuite/gfortran.dg/typebound_proc_2.f90 +++ b/gcc/testsuite/gfortran.dg/typebound_proc_2.f90 @@ -9,24 +9,23 @@ MODULE testmod TYPE t INTEGER :: x - CONTAINS ! { dg-error "Fortran 2003" } - PROCEDURE proc1 ! { dg-error "Fortran 2003" } - PROCEDURE :: proc2 => p2 ! { dg-error "Fortran 2003" } - END TYPE t + CONTAINS ! { dg-error "Fortran 2003: CONTAINS block in derived type definition" } + PROCEDURE proc1 ! { dg-error "Fortran 2003: PROCEDURE statement" } + PROCEDURE :: proc2 => p2 ! { dg-error "Fortran 2003: PROCEDURE statement" } + END TYPE t ! { dg-error "Fortran 2008: Derived type definition at .1. with empty CONTAINS section" } CONTAINS - SUBROUTINE proc1 (me) + SUBROUTINE proc1 (me) ! { dg-error "no IMPLICIT type" } IMPLICIT NONE - TYPE(t1) :: me + TYPE(t1) :: me ! { dg-error "being used before it is defined" } END SUBROUTINE proc1 - REAL FUNCTION proc2 (me, x) + REAL FUNCTION proc2 (me, x) ! { dg-error "no IMPLICIT type" } IMPLICIT NONE - TYPE(t1) :: me + TYPE(t1) :: me ! { dg-error "being used before it is defined" } REAL :: x proc2 = x / 2 END FUNCTION proc2 END MODULE testmod -! { dg-excess-errors "no IMPLICIT type" } diff --git a/gcc/testsuite/gfortran.dg/ubsan/bind-c-intent-out-2.f90 b/gcc/testsuite/gfortran.dg/ubsan/bind-c-intent-out-2.f90 new file mode 100644 index 0000000..fe8f606 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 diff --git a/gcc/testsuite/gfortran.dg/warnings_are_errors_1.f90 b/gcc/testsuite/gfortran.dg/warnings_are_errors_1.f90 index 150f234..1f9d38d 100644 --- a/gcc/testsuite/gfortran.dg/warnings_are_errors_1.f90 +++ b/gcc/testsuite/gfortran.dg/warnings_are_errors_1.f90 @@ -22,4 +22,4 @@ end ! { dg-final { output-exists-not } } -! { dg-excess-errors "warnings being treated as errors" } +! { dg-prune-output "warnings being treated as errors" } diff --git a/gcc/testsuite/gnat.dg/unroll1.adb b/gcc/testsuite/gnat.dg/unroll1.adb index 34d8a8f..8b732dd 100644 --- a/gcc/testsuite/gnat.dg/unroll1.adb +++ b/gcc/testsuite/gnat.dg/unroll1.adb @@ -1,5 +1,5 @@ -- { dg-do compile } --- { dg-options "-O2 -funroll-all-loops -fdump-rtl-loop2_unroll-details -fdump-tree-cunrolli-details" } +-- { dg-options "-O2 -funroll-all-loops -fno-tree-vectorize -fdump-rtl-loop2_unroll-details -fdump-tree-cunrolli-details" } package body Unroll1 is diff --git a/gcc/testsuite/lib/prune.exp b/gcc/testsuite/lib/prune.exp index fac212e..1314248 100644 --- a/gcc/testsuite/lib/prune.exp +++ b/gcc/testsuite/lib/prune.exp @@ -93,6 +93,9 @@ proc prune_gcc_output { text } { # Ignore dsymutil warning (tool bug is actually linker) regsub -all "(^|\n)\[^\n\]*could not find object file symbol for symbol\[^\n\]*" $text "" text + # Ignore stabs obsoletion warnings + regsub -all "(^|\n)\[^\n\]*\[Ww\]arning: STABS debugging information is obsolete and not supported anymore\[^\n\]*" $text "" text + # If dg-enable-nn-line-numbers was provided, then obscure source-margin # line numbers by converting them to "NN" form. set text [maybe-handle-nn-line-numbers $text] diff --git a/gcc/testsuite/lib/target-supports.exp b/gcc/testsuite/lib/target-supports.exp index 9ebca7a..1c8b1eb 100644 --- a/gcc/testsuite/lib/target-supports.exp +++ b/gcc/testsuite/lib/target-supports.exp @@ -7580,6 +7580,188 @@ proc check_effective_target_vect_element_align_preferred { } { && [check_effective_target_vect_variable_length] }] } +# Return true if vectorization of v2qi/v4qi/v8qi/v16qi/v2hi store is enabed. +# Return zero if the desirable pattern isn't found. +# It's used by Warray-bounds/Wstringop-overflow testcases which are +# regressed by O2 vectorization, refer to PR102697/PR102462/PR102706 +proc check_vect_slp_aligned_store_usage { pattern macro } { + global tool + + set result [check_compile slp_aligned_store_usage assembly { + char a[16] __attribute__ ((aligned (16))); + short b[4] __attribute__((aligned(8))); + int c[4] __attribute__((aligned(16))); + #ifdef TEST_V8QI + void + foo () + { + a[0] = 0; + a[1] = 1; + a[2] = 2; + a[3] = 3; + a[4] = 4; + a[5] = 5; + a[6] = 6; + a[7] = 7; + } + #elif TEST_V16QI + void + foo1 () + { + a[0] = 0; + a[1] = 1; + a[2] = 2; + a[3] = 3; + a[4] = 4; + a[5] = 5; + a[6] = 6; + a[7] = 7; + a[8] = 8; + a[9] = 9; + a[10] = 10; + a[11] = 11; + a[12] = 12; + a[13] = 13; + a[14] = 14; + a[15] = 15; + } + #elif TEST_V4QI + void + foo2 () + { + a[0] = 0; + a[1] = 1; + a[2] = 2; + a[3] = 3; + } + #elif TEST_V2QI + void + foo3 () + { + a[0] = 0; + a[1] = 1; + } + #elif TEST_V2HI + void + foo4 () + { + b[0] = 0; + b[1] = 1; + } + #elif TEST_V4HI + void + foo5 () + { + b[0] = 0; + b[1] = 1; + b[2] = 2; + b[3] = 3; + } + #elif TEST_V2SI + void + foo6 () + { + c[0] = 0; + c[1] = 1; + } + #elif TEST_V4SI + void + foo7 () + { + c[0] = 0; + c[1] = 1; + c[2] = 2; + c[3] = 3; + } + #endif + } "-O2 -fopt-info-all -D$macro" ] + + # Get compiler emitted messages and delete generated file. + set lines [lindex $result 0] + set output [lindex $result 1] + remote_file build delete $output + + # Check pattern exits in lines, set it to zero if not found. + if { [regexp $pattern $lines] } then { + return 1 + } + + return 0 +} + +# Return the true if target support vectorization of 2-byte char stores +# with 2-byte aligned address at plain O2. +proc check_effective_target_vect_slp_v2qi_store { } { + set pattern {add new stmt: MEM <vector\(2\) char>} + set macro "TEST_V2QI" + return [check_cached_effective_target vect_slp_v2qi_store { + expr [check_vect_slp_aligned_store_usage $pattern $macro] }] + +} + +# Return the true if target support vectorization of 4-byte char stores +# with 4-byte aligned address at plain O2. +proc check_effective_target_vect_slp_v4qi_store { } { + set pattern {add new stmt: MEM <vector\(4\) char>} + set macro "TEST_V4QI" + return [check_cached_effective_target vect_slp_v4qi_store { + expr [check_vect_slp_aligned_store_usage $pattern $macro ] }] +} + +# Return the true if target support vectorization of 8-byte char stores +# with 8-byte aligned address at plain O2. +proc check_effective_target_vect_slp_v8qi_store { } { + set pattern {add new stmt: MEM <vector\(8\) char>} + set macro "TEST_V8QI" + return [check_cached_effective_target vect_slp_v8qi_store { + expr [check_vect_slp_aligned_store_usage $pattern $macro ] }] +} + +# Return the true if target support vectorization of 16-byte char stores +# with 16-byte aligned address at plain O2. +proc check_effective_target_vect_slp_v16qi_store { } { + set pattern {add new stmt: MEM <vector\(16\) char>} + set macro "TEST_V16QI" + return [check_cached_effective_target vect_slp_v16qi_store { + expr [check_vect_slp_aligned_store_usage $pattern $macro ] }] +} + +# Return the true if target support vectorization of 4-byte short stores +# with 4-byte aligned address at plain O2. +proc check_effective_target_vect_slp_v2hi_store { } { + set pattern {add new stmt: MEM <vector\(2\) short int>} + set macro "TEST_V2HI" + return [check_cached_effective_target vect_slp_v2hi_store { + expr [check_vect_slp_aligned_store_usage $pattern $macro ] }] +} + +# Return the true if target support vectorization of 8-byte short stores +# with 8-byte aligned address at plain O2. +proc check_effective_target_vect_slp_v4hi_store { } { + set pattern {add new stmt: MEM <vector\(4\) short int>} + set macro "TEST_V4HI" + return [check_cached_effective_target vect_slp_v4hi_store { + expr [check_vect_slp_aligned_store_usage $pattern $macro ] }] +} + +# Return the true if target support vectorization of 8-byte int stores +# with 8-byte aligned address at plain O2. +proc check_effective_target_vect_slp_v2si_store { } { + set pattern {add new stmt: MEM <vector\(2\) int>} + set macro "TEST_V2SI" + return [check_cached_effective_target vect_slp_v2si_store { + expr [check_vect_slp_aligned_store_usage $pattern $macro ] }] +} + +# Return the true if target support vectorization of 16-byte int stores +# with 16-byte aligned address at plain O2. +proc check_effective_target_vect_slp_v4si_store { } { + set pattern {add new stmt: MEM <vector\(4\) int>} + set macro "TEST_V4SI" + return [check_cached_effective_target vect_slp_v4si_store { + expr [check_vect_slp_aligned_store_usage $pattern $macro ] }] +} + # Return 1 if we can align stack data to the preferred vector alignment. proc check_effective_target_vect_align_stack_vars { } { |