aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/openmp.cc
diff options
context:
space:
mode:
authorMartin Liska <mliska@suse.cz>2022-01-14 16:56:44 +0100
committerMartin Liska <mliska@suse.cz>2022-01-17 22:12:04 +0100
commit5c69acb32329d49e58c26fa41ae74229a52b9106 (patch)
treeddb05f9d73afb6f998457d2ac4b720e3b3b60483 /gcc/fortran/openmp.cc
parent490e23032baaece71f2ec09fa1805064b150fbc2 (diff)
downloadgcc-5c69acb32329d49e58c26fa41ae74229a52b9106.zip
gcc-5c69acb32329d49e58c26fa41ae74229a52b9106.tar.gz
gcc-5c69acb32329d49e58c26fa41ae74229a52b9106.tar.bz2
Rename .c files to .cc files.
gcc/ada/ChangeLog: * adadecode.c: Moved to... * adadecode.cc: ...here. * affinity.c: Moved to... * affinity.cc: ...here. * argv-lynxos178-raven-cert.c: Moved to... * argv-lynxos178-raven-cert.cc: ...here. * argv.c: Moved to... * argv.cc: ...here. * aux-io.c: Moved to... * aux-io.cc: ...here. * cio.c: Moved to... * cio.cc: ...here. * cstreams.c: Moved to... * cstreams.cc: ...here. * env.c: Moved to... * env.cc: ...here. * exit.c: Moved to... * exit.cc: ...here. * expect.c: Moved to... * expect.cc: ...here. * final.c: Moved to... * final.cc: ...here. * gcc-interface/cuintp.c: Moved to... * gcc-interface/cuintp.cc: ...here. * gcc-interface/decl.c: Moved to... * gcc-interface/decl.cc: ...here. * gcc-interface/misc.c: Moved to... * gcc-interface/misc.cc: ...here. * gcc-interface/targtyps.c: Moved to... * gcc-interface/targtyps.cc: ...here. * gcc-interface/trans.c: Moved to... * gcc-interface/trans.cc: ...here. * gcc-interface/utils.c: Moved to... * gcc-interface/utils.cc: ...here. * gcc-interface/utils2.c: Moved to... * gcc-interface/utils2.cc: ...here. * init.c: Moved to... * init.cc: ...here. * initialize.c: Moved to... * initialize.cc: ...here. * libgnarl/thread.c: Moved to... * libgnarl/thread.cc: ...here. * link.c: Moved to... * link.cc: ...here. * locales.c: Moved to... * locales.cc: ...here. * mkdir.c: Moved to... * mkdir.cc: ...here. * raise.c: Moved to... * raise.cc: ...here. * rtfinal.c: Moved to... * rtfinal.cc: ...here. * rtinit.c: Moved to... * rtinit.cc: ...here. * seh_init.c: Moved to... * seh_init.cc: ...here. * sigtramp-armdroid.c: Moved to... * sigtramp-armdroid.cc: ...here. * sigtramp-ios.c: Moved to... * sigtramp-ios.cc: ...here. * sigtramp-qnx.c: Moved to... * sigtramp-qnx.cc: ...here. * sigtramp-vxworks.c: Moved to... * sigtramp-vxworks.cc: ...here. * socket.c: Moved to... * socket.cc: ...here. * tracebak.c: Moved to... * tracebak.cc: ...here. * version.c: Moved to... * version.cc: ...here. * vx_stack_info.c: Moved to... * vx_stack_info.cc: ...here. gcc/ChangeLog: * adjust-alignment.c: Moved to... * adjust-alignment.cc: ...here. * alias.c: Moved to... * alias.cc: ...here. * alloc-pool.c: Moved to... * alloc-pool.cc: ...here. * asan.c: Moved to... * asan.cc: ...here. * attribs.c: Moved to... * attribs.cc: ...here. * auto-inc-dec.c: Moved to... * auto-inc-dec.cc: ...here. * auto-profile.c: Moved to... * auto-profile.cc: ...here. * bb-reorder.c: Moved to... * bb-reorder.cc: ...here. * bitmap.c: Moved to... * bitmap.cc: ...here. * btfout.c: Moved to... * btfout.cc: ...here. * builtins.c: Moved to... * builtins.cc: ...here. * caller-save.c: Moved to... * caller-save.cc: ...here. * calls.c: Moved to... * calls.cc: ...here. * ccmp.c: Moved to... * ccmp.cc: ...here. * cfg.c: Moved to... * cfg.cc: ...here. * cfganal.c: Moved to... * cfganal.cc: ...here. * cfgbuild.c: Moved to... * cfgbuild.cc: ...here. * cfgcleanup.c: Moved to... * cfgcleanup.cc: ...here. * cfgexpand.c: Moved to... * cfgexpand.cc: ...here. * cfghooks.c: Moved to... * cfghooks.cc: ...here. * cfgloop.c: Moved to... * cfgloop.cc: ...here. * cfgloopanal.c: Moved to... * cfgloopanal.cc: ...here. * cfgloopmanip.c: Moved to... * cfgloopmanip.cc: ...here. * cfgrtl.c: Moved to... * cfgrtl.cc: ...here. * cgraph.c: Moved to... * cgraph.cc: ...here. * cgraphbuild.c: Moved to... * cgraphbuild.cc: ...here. * cgraphclones.c: Moved to... * cgraphclones.cc: ...here. * cgraphunit.c: Moved to... * cgraphunit.cc: ...here. * collect-utils.c: Moved to... * collect-utils.cc: ...here. * collect2-aix.c: Moved to... * collect2-aix.cc: ...here. * collect2.c: Moved to... * collect2.cc: ...here. * combine-stack-adj.c: Moved to... * combine-stack-adj.cc: ...here. * combine.c: Moved to... * combine.cc: ...here. * common/common-targhooks.c: Moved to... * common/common-targhooks.cc: ...here. * common/config/aarch64/aarch64-common.c: Moved to... * common/config/aarch64/aarch64-common.cc: ...here. * common/config/alpha/alpha-common.c: Moved to... * common/config/alpha/alpha-common.cc: ...here. * common/config/arc/arc-common.c: Moved to... * common/config/arc/arc-common.cc: ...here. * common/config/arm/arm-common.c: Moved to... * common/config/arm/arm-common.cc: ...here. * common/config/avr/avr-common.c: Moved to... * common/config/avr/avr-common.cc: ...here. * common/config/bfin/bfin-common.c: Moved to... * common/config/bfin/bfin-common.cc: ...here. * common/config/bpf/bpf-common.c: Moved to... * common/config/bpf/bpf-common.cc: ...here. * common/config/c6x/c6x-common.c: Moved to... * common/config/c6x/c6x-common.cc: ...here. * common/config/cr16/cr16-common.c: Moved to... * common/config/cr16/cr16-common.cc: ...here. * common/config/cris/cris-common.c: Moved to... * common/config/cris/cris-common.cc: ...here. * common/config/csky/csky-common.c: Moved to... * common/config/csky/csky-common.cc: ...here. * common/config/default-common.c: Moved to... * common/config/default-common.cc: ...here. * common/config/epiphany/epiphany-common.c: Moved to... * common/config/epiphany/epiphany-common.cc: ...here. * common/config/fr30/fr30-common.c: Moved to... * common/config/fr30/fr30-common.cc: ...here. * common/config/frv/frv-common.c: Moved to... * common/config/frv/frv-common.cc: ...here. * common/config/gcn/gcn-common.c: Moved to... * common/config/gcn/gcn-common.cc: ...here. * common/config/h8300/h8300-common.c: Moved to... * common/config/h8300/h8300-common.cc: ...here. * common/config/i386/i386-common.c: Moved to... * common/config/i386/i386-common.cc: ...here. * common/config/ia64/ia64-common.c: Moved to... * common/config/ia64/ia64-common.cc: ...here. * common/config/iq2000/iq2000-common.c: Moved to... * common/config/iq2000/iq2000-common.cc: ...here. * common/config/lm32/lm32-common.c: Moved to... * common/config/lm32/lm32-common.cc: ...here. * common/config/m32r/m32r-common.c: Moved to... * common/config/m32r/m32r-common.cc: ...here. * common/config/m68k/m68k-common.c: Moved to... * common/config/m68k/m68k-common.cc: ...here. * common/config/mcore/mcore-common.c: Moved to... * common/config/mcore/mcore-common.cc: ...here. * common/config/microblaze/microblaze-common.c: Moved to... * common/config/microblaze/microblaze-common.cc: ...here. * common/config/mips/mips-common.c: Moved to... * common/config/mips/mips-common.cc: ...here. * common/config/mmix/mmix-common.c: Moved to... * common/config/mmix/mmix-common.cc: ...here. * common/config/mn10300/mn10300-common.c: Moved to... * common/config/mn10300/mn10300-common.cc: ...here. * common/config/msp430/msp430-common.c: Moved to... * common/config/msp430/msp430-common.cc: ...here. * common/config/nds32/nds32-common.c: Moved to... * common/config/nds32/nds32-common.cc: ...here. * common/config/nios2/nios2-common.c: Moved to... * common/config/nios2/nios2-common.cc: ...here. * common/config/nvptx/nvptx-common.c: Moved to... * common/config/nvptx/nvptx-common.cc: ...here. * common/config/or1k/or1k-common.c: Moved to... * common/config/or1k/or1k-common.cc: ...here. * common/config/pa/pa-common.c: Moved to... * common/config/pa/pa-common.cc: ...here. * common/config/pdp11/pdp11-common.c: Moved to... * common/config/pdp11/pdp11-common.cc: ...here. * common/config/pru/pru-common.c: Moved to... * common/config/pru/pru-common.cc: ...here. * common/config/riscv/riscv-common.c: Moved to... * common/config/riscv/riscv-common.cc: ...here. * common/config/rs6000/rs6000-common.c: Moved to... * common/config/rs6000/rs6000-common.cc: ...here. * common/config/rx/rx-common.c: Moved to... * common/config/rx/rx-common.cc: ...here. * common/config/s390/s390-common.c: Moved to... * common/config/s390/s390-common.cc: ...here. * common/config/sh/sh-common.c: Moved to... * common/config/sh/sh-common.cc: ...here. * common/config/sparc/sparc-common.c: Moved to... * common/config/sparc/sparc-common.cc: ...here. * common/config/tilegx/tilegx-common.c: Moved to... * common/config/tilegx/tilegx-common.cc: ...here. * common/config/tilepro/tilepro-common.c: Moved to... * common/config/tilepro/tilepro-common.cc: ...here. * common/config/v850/v850-common.c: Moved to... * common/config/v850/v850-common.cc: ...here. * common/config/vax/vax-common.c: Moved to... * common/config/vax/vax-common.cc: ...here. * common/config/visium/visium-common.c: Moved to... * common/config/visium/visium-common.cc: ...here. * common/config/xstormy16/xstormy16-common.c: Moved to... * common/config/xstormy16/xstormy16-common.cc: ...here. * common/config/xtensa/xtensa-common.c: Moved to... * common/config/xtensa/xtensa-common.cc: ...here. * compare-elim.c: Moved to... * compare-elim.cc: ...here. * config/aarch64/aarch64-bti-insert.c: Moved to... * config/aarch64/aarch64-bti-insert.cc: ...here. * config/aarch64/aarch64-builtins.c: Moved to... * config/aarch64/aarch64-builtins.cc: ...here. * config/aarch64/aarch64-c.c: Moved to... * config/aarch64/aarch64-c.cc: ...here. * config/aarch64/aarch64-d.c: Moved to... * config/aarch64/aarch64-d.cc: ...here. * config/aarch64/aarch64.c: Moved to... * config/aarch64/aarch64.cc: ...here. * config/aarch64/cortex-a57-fma-steering.c: Moved to... * config/aarch64/cortex-a57-fma-steering.cc: ...here. * config/aarch64/driver-aarch64.c: Moved to... * config/aarch64/driver-aarch64.cc: ...here. * config/aarch64/falkor-tag-collision-avoidance.c: Moved to... * config/aarch64/falkor-tag-collision-avoidance.cc: ...here. * config/aarch64/host-aarch64-darwin.c: Moved to... * config/aarch64/host-aarch64-darwin.cc: ...here. * config/alpha/alpha.c: Moved to... * config/alpha/alpha.cc: ...here. * config/alpha/driver-alpha.c: Moved to... * config/alpha/driver-alpha.cc: ...here. * config/arc/arc-c.c: Moved to... * config/arc/arc-c.cc: ...here. * config/arc/arc.c: Moved to... * config/arc/arc.cc: ...here. * config/arc/driver-arc.c: Moved to... * config/arc/driver-arc.cc: ...here. * config/arm/aarch-common.c: Moved to... * config/arm/aarch-common.cc: ...here. * config/arm/arm-builtins.c: Moved to... * config/arm/arm-builtins.cc: ...here. * config/arm/arm-c.c: Moved to... * config/arm/arm-c.cc: ...here. * config/arm/arm-d.c: Moved to... * config/arm/arm-d.cc: ...here. * config/arm/arm.c: Moved to... * config/arm/arm.cc: ...here. * config/arm/driver-arm.c: Moved to... * config/arm/driver-arm.cc: ...here. * config/avr/avr-c.c: Moved to... * config/avr/avr-c.cc: ...here. * config/avr/avr-devices.c: Moved to... * config/avr/avr-devices.cc: ...here. * config/avr/avr-log.c: Moved to... * config/avr/avr-log.cc: ...here. * config/avr/avr.c: Moved to... * config/avr/avr.cc: ...here. * config/avr/driver-avr.c: Moved to... * config/avr/driver-avr.cc: ...here. * config/avr/gen-avr-mmcu-specs.c: Moved to... * config/avr/gen-avr-mmcu-specs.cc: ...here. * config/avr/gen-avr-mmcu-texi.c: Moved to... * config/avr/gen-avr-mmcu-texi.cc: ...here. * config/bfin/bfin.c: Moved to... * config/bfin/bfin.cc: ...here. * config/bpf/bpf.c: Moved to... * config/bpf/bpf.cc: ...here. * config/bpf/coreout.c: Moved to... * config/bpf/coreout.cc: ...here. * config/c6x/c6x.c: Moved to... * config/c6x/c6x.cc: ...here. * config/cr16/cr16.c: Moved to... * config/cr16/cr16.cc: ...here. * config/cris/cris.c: Moved to... * config/cris/cris.cc: ...here. * config/csky/csky.c: Moved to... * config/csky/csky.cc: ...here. * config/darwin-c.c: Moved to... * config/darwin-c.cc: ...here. * config/darwin-d.c: Moved to... * config/darwin-d.cc: ...here. * config/darwin-driver.c: Moved to... * config/darwin-driver.cc: ...here. * config/darwin-f.c: Moved to... * config/darwin-f.cc: ...here. * config/darwin.c: Moved to... * config/darwin.cc: ...here. * config/default-c.c: Moved to... * config/default-c.cc: ...here. * config/default-d.c: Moved to... * config/default-d.cc: ...here. * config/dragonfly-d.c: Moved to... * config/dragonfly-d.cc: ...here. * config/epiphany/epiphany.c: Moved to... * config/epiphany/epiphany.cc: ...here. * config/epiphany/mode-switch-use.c: Moved to... * config/epiphany/mode-switch-use.cc: ...here. * config/epiphany/resolve-sw-modes.c: Moved to... * config/epiphany/resolve-sw-modes.cc: ...here. * config/fr30/fr30.c: Moved to... * config/fr30/fr30.cc: ...here. * config/freebsd-d.c: Moved to... * config/freebsd-d.cc: ...here. * config/frv/frv.c: Moved to... * config/frv/frv.cc: ...here. * config/ft32/ft32.c: Moved to... * config/ft32/ft32.cc: ...here. * config/gcn/driver-gcn.c: Moved to... * config/gcn/driver-gcn.cc: ...here. * config/gcn/gcn-run.c: Moved to... * config/gcn/gcn-run.cc: ...here. * config/gcn/gcn-tree.c: Moved to... * config/gcn/gcn-tree.cc: ...here. * config/gcn/gcn.c: Moved to... * config/gcn/gcn.cc: ...here. * config/gcn/mkoffload.c: Moved to... * config/gcn/mkoffload.cc: ...here. * config/glibc-c.c: Moved to... * config/glibc-c.cc: ...here. * config/glibc-d.c: Moved to... * config/glibc-d.cc: ...here. * config/h8300/h8300.c: Moved to... * config/h8300/h8300.cc: ...here. * config/host-darwin.c: Moved to... * config/host-darwin.cc: ...here. * config/host-hpux.c: Moved to... * config/host-hpux.cc: ...here. * config/host-linux.c: Moved to... * config/host-linux.cc: ...here. * config/host-netbsd.c: Moved to... * config/host-netbsd.cc: ...here. * config/host-openbsd.c: Moved to... * config/host-openbsd.cc: ...here. * config/host-solaris.c: Moved to... * config/host-solaris.cc: ...here. * config/i386/djgpp.c: Moved to... * config/i386/djgpp.cc: ...here. * config/i386/driver-i386.c: Moved to... * config/i386/driver-i386.cc: ...here. * config/i386/driver-mingw32.c: Moved to... * config/i386/driver-mingw32.cc: ...here. * config/i386/gnu-property.c: Moved to... * config/i386/gnu-property.cc: ...here. * config/i386/host-cygwin.c: Moved to... * config/i386/host-cygwin.cc: ...here. * config/i386/host-i386-darwin.c: Moved to... * config/i386/host-i386-darwin.cc: ...here. * config/i386/host-mingw32.c: Moved to... * config/i386/host-mingw32.cc: ...here. * config/i386/i386-builtins.c: Moved to... * config/i386/i386-builtins.cc: ...here. * config/i386/i386-c.c: Moved to... * config/i386/i386-c.cc: ...here. * config/i386/i386-d.c: Moved to... * config/i386/i386-d.cc: ...here. * config/i386/i386-expand.c: Moved to... * config/i386/i386-expand.cc: ...here. * config/i386/i386-features.c: Moved to... * config/i386/i386-features.cc: ...here. * config/i386/i386-options.c: Moved to... * config/i386/i386-options.cc: ...here. * config/i386/i386.c: Moved to... * config/i386/i386.cc: ...here. * config/i386/intelmic-mkoffload.c: Moved to... * config/i386/intelmic-mkoffload.cc: ...here. * config/i386/msformat-c.c: Moved to... * config/i386/msformat-c.cc: ...here. * config/i386/winnt-cxx.c: Moved to... * config/i386/winnt-cxx.cc: ...here. * config/i386/winnt-d.c: Moved to... * config/i386/winnt-d.cc: ...here. * config/i386/winnt-stubs.c: Moved to... * config/i386/winnt-stubs.cc: ...here. * config/i386/winnt.c: Moved to... * config/i386/winnt.cc: ...here. * config/i386/x86-tune-sched-atom.c: Moved to... * config/i386/x86-tune-sched-atom.cc: ...here. * config/i386/x86-tune-sched-bd.c: Moved to... * config/i386/x86-tune-sched-bd.cc: ...here. * config/i386/x86-tune-sched-core.c: Moved to... * config/i386/x86-tune-sched-core.cc: ...here. * config/i386/x86-tune-sched.c: Moved to... * config/i386/x86-tune-sched.cc: ...here. * config/ia64/ia64-c.c: Moved to... * config/ia64/ia64-c.cc: ...here. * config/ia64/ia64.c: Moved to... * config/ia64/ia64.cc: ...here. * config/iq2000/iq2000.c: Moved to... * config/iq2000/iq2000.cc: ...here. * config/linux.c: Moved to... * config/linux.cc: ...here. * config/lm32/lm32.c: Moved to... * config/lm32/lm32.cc: ...here. * config/m32c/m32c-pragma.c: Moved to... * config/m32c/m32c-pragma.cc: ...here. * config/m32c/m32c.c: Moved to... * config/m32c/m32c.cc: ...here. * config/m32r/m32r.c: Moved to... * config/m32r/m32r.cc: ...here. * config/m68k/m68k.c: Moved to... * config/m68k/m68k.cc: ...here. * config/mcore/mcore.c: Moved to... * config/mcore/mcore.cc: ...here. * config/microblaze/microblaze-c.c: Moved to... * config/microblaze/microblaze-c.cc: ...here. * config/microblaze/microblaze.c: Moved to... * config/microblaze/microblaze.cc: ...here. * config/mips/driver-native.c: Moved to... * config/mips/driver-native.cc: ...here. * config/mips/frame-header-opt.c: Moved to... * config/mips/frame-header-opt.cc: ...here. * config/mips/mips-d.c: Moved to... * config/mips/mips-d.cc: ...here. * config/mips/mips.c: Moved to... * config/mips/mips.cc: ...here. * config/mmix/mmix.c: Moved to... * config/mmix/mmix.cc: ...here. * config/mn10300/mn10300.c: Moved to... * config/mn10300/mn10300.cc: ...here. * config/moxie/moxie.c: Moved to... * config/moxie/moxie.cc: ...here. * config/msp430/driver-msp430.c: Moved to... * config/msp430/driver-msp430.cc: ...here. * config/msp430/msp430-c.c: Moved to... * config/msp430/msp430-c.cc: ...here. * config/msp430/msp430-devices.c: Moved to... * config/msp430/msp430-devices.cc: ...here. * config/msp430/msp430.c: Moved to... * config/msp430/msp430.cc: ...here. * config/nds32/nds32-cost.c: Moved to... * config/nds32/nds32-cost.cc: ...here. * config/nds32/nds32-fp-as-gp.c: Moved to... * config/nds32/nds32-fp-as-gp.cc: ...here. * config/nds32/nds32-intrinsic.c: Moved to... * config/nds32/nds32-intrinsic.cc: ...here. * config/nds32/nds32-isr.c: Moved to... * config/nds32/nds32-isr.cc: ...here. * config/nds32/nds32-md-auxiliary.c: Moved to... * config/nds32/nds32-md-auxiliary.cc: ...here. * config/nds32/nds32-memory-manipulation.c: Moved to... * config/nds32/nds32-memory-manipulation.cc: ...here. * config/nds32/nds32-pipelines-auxiliary.c: Moved to... * config/nds32/nds32-pipelines-auxiliary.cc: ...here. * config/nds32/nds32-predicates.c: Moved to... * config/nds32/nds32-predicates.cc: ...here. * config/nds32/nds32-relax-opt.c: Moved to... * config/nds32/nds32-relax-opt.cc: ...here. * config/nds32/nds32-utils.c: Moved to... * config/nds32/nds32-utils.cc: ...here. * config/nds32/nds32.c: Moved to... * config/nds32/nds32.cc: ...here. * config/netbsd-d.c: Moved to... * config/netbsd-d.cc: ...here. * config/netbsd.c: Moved to... * config/netbsd.cc: ...here. * config/nios2/nios2.c: Moved to... * config/nios2/nios2.cc: ...here. * config/nvptx/mkoffload.c: Moved to... * config/nvptx/mkoffload.cc: ...here. * config/nvptx/nvptx-c.c: Moved to... * config/nvptx/nvptx-c.cc: ...here. * config/nvptx/nvptx.c: Moved to... * config/nvptx/nvptx.cc: ...here. * config/openbsd-d.c: Moved to... * config/openbsd-d.cc: ...here. * config/or1k/or1k.c: Moved to... * config/or1k/or1k.cc: ...here. * config/pa/pa-d.c: Moved to... * config/pa/pa-d.cc: ...here. * config/pa/pa.c: Moved to... * config/pa/pa.cc: ...here. * config/pdp11/pdp11.c: Moved to... * config/pdp11/pdp11.cc: ...here. * config/pru/pru-passes.c: Moved to... * config/pru/pru-passes.cc: ...here. * config/pru/pru-pragma.c: Moved to... * config/pru/pru-pragma.cc: ...here. * config/pru/pru.c: Moved to... * config/pru/pru.cc: ...here. * config/riscv/riscv-builtins.c: Moved to... * config/riscv/riscv-builtins.cc: ...here. * config/riscv/riscv-c.c: Moved to... * config/riscv/riscv-c.cc: ...here. * config/riscv/riscv-d.c: Moved to... * config/riscv/riscv-d.cc: ...here. * config/riscv/riscv-shorten-memrefs.c: Moved to... * config/riscv/riscv-shorten-memrefs.cc: ...here. * config/riscv/riscv-sr.c: Moved to... * config/riscv/riscv-sr.cc: ...here. * config/riscv/riscv.c: Moved to... * config/riscv/riscv.cc: ...here. * config/rl78/rl78-c.c: Moved to... * config/rl78/rl78-c.cc: ...here. * config/rl78/rl78.c: Moved to... * config/rl78/rl78.cc: ...here. * config/rs6000/driver-rs6000.c: Moved to... * config/rs6000/driver-rs6000.cc: ...here. * config/rs6000/host-darwin.c: Moved to... * config/rs6000/host-darwin.cc: ...here. * config/rs6000/host-ppc64-darwin.c: Moved to... * config/rs6000/host-ppc64-darwin.cc: ...here. * config/rs6000/rbtree.c: Moved to... * config/rs6000/rbtree.cc: ...here. * config/rs6000/rs6000-c.c: Moved to... * config/rs6000/rs6000-c.cc: ...here. * config/rs6000/rs6000-call.c: Moved to... * config/rs6000/rs6000-call.cc: ...here. * config/rs6000/rs6000-d.c: Moved to... * config/rs6000/rs6000-d.cc: ...here. * config/rs6000/rs6000-gen-builtins.c: Moved to... * config/rs6000/rs6000-gen-builtins.cc: ...here. * config/rs6000/rs6000-linux.c: Moved to... * config/rs6000/rs6000-linux.cc: ...here. * config/rs6000/rs6000-logue.c: Moved to... * config/rs6000/rs6000-logue.cc: ...here. * config/rs6000/rs6000-p8swap.c: Moved to... * config/rs6000/rs6000-p8swap.cc: ...here. * config/rs6000/rs6000-pcrel-opt.c: Moved to... * config/rs6000/rs6000-pcrel-opt.cc: ...here. * config/rs6000/rs6000-string.c: Moved to... * config/rs6000/rs6000-string.cc: ...here. * config/rs6000/rs6000.c: Moved to... * config/rs6000/rs6000.cc: ...here. * config/rx/rx.c: Moved to... * config/rx/rx.cc: ...here. * config/s390/driver-native.c: Moved to... * config/s390/driver-native.cc: ...here. * config/s390/s390-c.c: Moved to... * config/s390/s390-c.cc: ...here. * config/s390/s390-d.c: Moved to... * config/s390/s390-d.cc: ...here. * config/s390/s390.c: Moved to... * config/s390/s390.cc: ...here. * config/sh/divtab-sh4-300.c: Moved to... * config/sh/divtab-sh4-300.cc: ...here. * config/sh/divtab-sh4.c: Moved to... * config/sh/divtab-sh4.cc: ...here. * config/sh/divtab.c: Moved to... * config/sh/divtab.cc: ...here. * config/sh/sh-c.c: Moved to... * config/sh/sh-c.cc: ...here. * config/sh/sh.c: Moved to... * config/sh/sh.cc: ...here. * config/sol2-c.c: Moved to... * config/sol2-c.cc: ...here. * config/sol2-cxx.c: Moved to... * config/sol2-cxx.cc: ...here. * config/sol2-d.c: Moved to... * config/sol2-d.cc: ...here. * config/sol2-stubs.c: Moved to... * config/sol2-stubs.cc: ...here. * config/sol2.c: Moved to... * config/sol2.cc: ...here. * config/sparc/driver-sparc.c: Moved to... * config/sparc/driver-sparc.cc: ...here. * config/sparc/sparc-c.c: Moved to... * config/sparc/sparc-c.cc: ...here. * config/sparc/sparc-d.c: Moved to... * config/sparc/sparc-d.cc: ...here. * config/sparc/sparc.c: Moved to... * config/sparc/sparc.cc: ...here. * config/stormy16/stormy16.c: Moved to... * config/stormy16/stormy16.cc: ...here. * config/tilegx/mul-tables.c: Moved to... * config/tilegx/mul-tables.cc: ...here. * config/tilegx/tilegx-c.c: Moved to... * config/tilegx/tilegx-c.cc: ...here. * config/tilegx/tilegx.c: Moved to... * config/tilegx/tilegx.cc: ...here. * config/tilepro/mul-tables.c: Moved to... * config/tilepro/mul-tables.cc: ...here. * config/tilepro/tilepro-c.c: Moved to... * config/tilepro/tilepro-c.cc: ...here. * config/tilepro/tilepro.c: Moved to... * config/tilepro/tilepro.cc: ...here. * config/v850/v850-c.c: Moved to... * config/v850/v850-c.cc: ...here. * config/v850/v850.c: Moved to... * config/v850/v850.cc: ...here. * config/vax/vax.c: Moved to... * config/vax/vax.cc: ...here. * config/visium/visium.c: Moved to... * config/visium/visium.cc: ...here. * config/vms/vms-c.c: Moved to... * config/vms/vms-c.cc: ...here. * config/vms/vms-f.c: Moved to... * config/vms/vms-f.cc: ...here. * config/vms/vms.c: Moved to... * config/vms/vms.cc: ...here. * config/vxworks-c.c: Moved to... * config/vxworks-c.cc: ...here. * config/vxworks.c: Moved to... * config/vxworks.cc: ...here. * config/winnt-c.c: Moved to... * config/winnt-c.cc: ...here. * config/xtensa/xtensa.c: Moved to... * config/xtensa/xtensa.cc: ...here. * context.c: Moved to... * context.cc: ...here. * convert.c: Moved to... * convert.cc: ...here. * coverage.c: Moved to... * coverage.cc: ...here. * cppbuiltin.c: Moved to... * cppbuiltin.cc: ...here. * cppdefault.c: Moved to... * cppdefault.cc: ...here. * cprop.c: Moved to... * cprop.cc: ...here. * cse.c: Moved to... * cse.cc: ...here. * cselib.c: Moved to... * cselib.cc: ...here. * ctfc.c: Moved to... * ctfc.cc: ...here. * ctfout.c: Moved to... * ctfout.cc: ...here. * data-streamer-in.c: Moved to... * data-streamer-in.cc: ...here. * data-streamer-out.c: Moved to... * data-streamer-out.cc: ...here. * data-streamer.c: Moved to... * data-streamer.cc: ...here. * dbgcnt.c: Moved to... * dbgcnt.cc: ...here. * dbxout.c: Moved to... * dbxout.cc: ...here. * dce.c: Moved to... * dce.cc: ...here. * ddg.c: Moved to... * ddg.cc: ...here. * debug.c: Moved to... * debug.cc: ...here. * df-core.c: Moved to... * df-core.cc: ...here. * df-problems.c: Moved to... * df-problems.cc: ...here. * df-scan.c: Moved to... * df-scan.cc: ...here. * dfp.c: Moved to... * dfp.cc: ...here. * diagnostic-color.c: Moved to... * diagnostic-color.cc: ...here. * diagnostic-show-locus.c: Moved to... * diagnostic-show-locus.cc: ...here. * diagnostic-spec.c: Moved to... * diagnostic-spec.cc: ...here. * diagnostic.c: Moved to... * diagnostic.cc: ...here. * dojump.c: Moved to... * dojump.cc: ...here. * dominance.c: Moved to... * dominance.cc: ...here. * domwalk.c: Moved to... * domwalk.cc: ...here. * double-int.c: Moved to... * double-int.cc: ...here. * dse.c: Moved to... * dse.cc: ...here. * dumpfile.c: Moved to... * dumpfile.cc: ...here. * dwarf2asm.c: Moved to... * dwarf2asm.cc: ...here. * dwarf2cfi.c: Moved to... * dwarf2cfi.cc: ...here. * dwarf2ctf.c: Moved to... * dwarf2ctf.cc: ...here. * dwarf2out.c: Moved to... * dwarf2out.cc: ...here. * early-remat.c: Moved to... * early-remat.cc: ...here. * edit-context.c: Moved to... * edit-context.cc: ...here. * emit-rtl.c: Moved to... * emit-rtl.cc: ...here. * errors.c: Moved to... * errors.cc: ...here. * et-forest.c: Moved to... * et-forest.cc: ...here. * except.c: Moved to... * except.cc: ...here. * explow.c: Moved to... * explow.cc: ...here. * expmed.c: Moved to... * expmed.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * fibonacci_heap.c: Moved to... * fibonacci_heap.cc: ...here. * file-find.c: Moved to... * file-find.cc: ...here. * file-prefix-map.c: Moved to... * file-prefix-map.cc: ...here. * final.c: Moved to... * final.cc: ...here. * fixed-value.c: Moved to... * fixed-value.cc: ...here. * fold-const-call.c: Moved to... * fold-const-call.cc: ...here. * fold-const.c: Moved to... * fold-const.cc: ...here. * fp-test.c: Moved to... * fp-test.cc: ...here. * function-tests.c: Moved to... * function-tests.cc: ...here. * function.c: Moved to... * function.cc: ...here. * fwprop.c: Moved to... * fwprop.cc: ...here. * gcc-ar.c: Moved to... * gcc-ar.cc: ...here. * gcc-main.c: Moved to... * gcc-main.cc: ...here. * gcc-rich-location.c: Moved to... * gcc-rich-location.cc: ...here. * gcc.c: Moved to... * gcc.cc: ...here. * gcov-dump.c: Moved to... * gcov-dump.cc: ...here. * gcov-io.c: Moved to... * gcov-io.cc: ...here. * gcov-tool.c: Moved to... * gcov-tool.cc: ...here. * gcov.c: Moved to... * gcov.cc: ...here. * gcse-common.c: Moved to... * gcse-common.cc: ...here. * gcse.c: Moved to... * gcse.cc: ...here. * genattr-common.c: Moved to... * genattr-common.cc: ...here. * genattr.c: Moved to... * genattr.cc: ...here. * genattrtab.c: Moved to... * genattrtab.cc: ...here. * genautomata.c: Moved to... * genautomata.cc: ...here. * gencfn-macros.c: Moved to... * gencfn-macros.cc: ...here. * gencheck.c: Moved to... * gencheck.cc: ...here. * genchecksum.c: Moved to... * genchecksum.cc: ...here. * gencodes.c: Moved to... * gencodes.cc: ...here. * genconditions.c: Moved to... * genconditions.cc: ...here. * genconfig.c: Moved to... * genconfig.cc: ...here. * genconstants.c: Moved to... * genconstants.cc: ...here. * genemit.c: Moved to... * genemit.cc: ...here. * genenums.c: Moved to... * genenums.cc: ...here. * generic-match-head.c: Moved to... * generic-match-head.cc: ...here. * genextract.c: Moved to... * genextract.cc: ...here. * genflags.c: Moved to... * genflags.cc: ...here. * gengenrtl.c: Moved to... * gengenrtl.cc: ...here. * gengtype-parse.c: Moved to... * gengtype-parse.cc: ...here. * gengtype-state.c: Moved to... * gengtype-state.cc: ...here. * gengtype.c: Moved to... * gengtype.cc: ...here. * genhooks.c: Moved to... * genhooks.cc: ...here. * genmatch.c: Moved to... * genmatch.cc: ...here. * genmddeps.c: Moved to... * genmddeps.cc: ...here. * genmddump.c: Moved to... * genmddump.cc: ...here. * genmodes.c: Moved to... * genmodes.cc: ...here. * genopinit.c: Moved to... * genopinit.cc: ...here. * genoutput.c: Moved to... * genoutput.cc: ...here. * genpeep.c: Moved to... * genpeep.cc: ...here. * genpreds.c: Moved to... * genpreds.cc: ...here. * genrecog.c: Moved to... * genrecog.cc: ...here. * gensupport.c: Moved to... * gensupport.cc: ...here. * gentarget-def.c: Moved to... * gentarget-def.cc: ...here. * genversion.c: Moved to... * genversion.cc: ...here. * ggc-common.c: Moved to... * ggc-common.cc: ...here. * ggc-none.c: Moved to... * ggc-none.cc: ...here. * ggc-page.c: Moved to... * ggc-page.cc: ...here. * ggc-tests.c: Moved to... * ggc-tests.cc: ...here. * gimple-builder.c: Moved to... * gimple-builder.cc: ...here. * gimple-expr.c: Moved to... * gimple-expr.cc: ...here. * gimple-fold.c: Moved to... * gimple-fold.cc: ...here. * gimple-iterator.c: Moved to... * gimple-iterator.cc: ...here. * gimple-laddress.c: Moved to... * gimple-laddress.cc: ...here. * gimple-loop-jam.c: Moved to... * gimple-loop-jam.cc: ...here. * gimple-low.c: Moved to... * gimple-low.cc: ...here. * gimple-match-head.c: Moved to... * gimple-match-head.cc: ...here. * gimple-pretty-print.c: Moved to... * gimple-pretty-print.cc: ...here. * gimple-ssa-backprop.c: Moved to... * gimple-ssa-backprop.cc: ...here. * gimple-ssa-evrp-analyze.c: Moved to... * gimple-ssa-evrp-analyze.cc: ...here. * gimple-ssa-evrp.c: Moved to... * gimple-ssa-evrp.cc: ...here. * gimple-ssa-isolate-paths.c: Moved to... * gimple-ssa-isolate-paths.cc: ...here. * gimple-ssa-nonnull-compare.c: Moved to... * gimple-ssa-nonnull-compare.cc: ...here. * gimple-ssa-split-paths.c: Moved to... * gimple-ssa-split-paths.cc: ...here. * gimple-ssa-sprintf.c: Moved to... * gimple-ssa-sprintf.cc: ...here. * gimple-ssa-store-merging.c: Moved to... * gimple-ssa-store-merging.cc: ...here. * gimple-ssa-strength-reduction.c: Moved to... * gimple-ssa-strength-reduction.cc: ...here. * gimple-ssa-warn-alloca.c: Moved to... * gimple-ssa-warn-alloca.cc: ...here. * gimple-ssa-warn-restrict.c: Moved to... * gimple-ssa-warn-restrict.cc: ...here. * gimple-streamer-in.c: Moved to... * gimple-streamer-in.cc: ...here. * gimple-streamer-out.c: Moved to... * gimple-streamer-out.cc: ...here. * gimple-walk.c: Moved to... * gimple-walk.cc: ...here. * gimple-warn-recursion.c: Moved to... * gimple-warn-recursion.cc: ...here. * gimple.c: Moved to... * gimple.cc: ...here. * gimplify-me.c: Moved to... * gimplify-me.cc: ...here. * gimplify.c: Moved to... * gimplify.cc: ...here. * godump.c: Moved to... * godump.cc: ...here. * graph.c: Moved to... * graph.cc: ...here. * graphds.c: Moved to... * graphds.cc: ...here. * graphite-dependences.c: Moved to... * graphite-dependences.cc: ...here. * graphite-isl-ast-to-gimple.c: Moved to... * graphite-isl-ast-to-gimple.cc: ...here. * graphite-optimize-isl.c: Moved to... * graphite-optimize-isl.cc: ...here. * graphite-poly.c: Moved to... * graphite-poly.cc: ...here. * graphite-scop-detection.c: Moved to... * graphite-scop-detection.cc: ...here. * graphite-sese-to-poly.c: Moved to... * graphite-sese-to-poly.cc: ...here. * graphite.c: Moved to... * graphite.cc: ...here. * haifa-sched.c: Moved to... * haifa-sched.cc: ...here. * hash-map-tests.c: Moved to... * hash-map-tests.cc: ...here. * hash-set-tests.c: Moved to... * hash-set-tests.cc: ...here. * hash-table.c: Moved to... * hash-table.cc: ...here. * hooks.c: Moved to... * hooks.cc: ...here. * host-default.c: Moved to... * host-default.cc: ...here. * hw-doloop.c: Moved to... * hw-doloop.cc: ...here. * hwint.c: Moved to... * hwint.cc: ...here. * ifcvt.c: Moved to... * ifcvt.cc: ...here. * inchash.c: Moved to... * inchash.cc: ...here. * incpath.c: Moved to... * incpath.cc: ...here. * init-regs.c: Moved to... * init-regs.cc: ...here. * input.c: Moved to... * input.cc: ...here. * internal-fn.c: Moved to... * internal-fn.cc: ...here. * intl.c: Moved to... * intl.cc: ...here. * ipa-comdats.c: Moved to... * ipa-comdats.cc: ...here. * ipa-cp.c: Moved to... * ipa-cp.cc: ...here. * ipa-devirt.c: Moved to... * ipa-devirt.cc: ...here. * ipa-fnsummary.c: Moved to... * ipa-fnsummary.cc: ...here. * ipa-icf-gimple.c: Moved to... * ipa-icf-gimple.cc: ...here. * ipa-icf.c: Moved to... * ipa-icf.cc: ...here. * ipa-inline-analysis.c: Moved to... * ipa-inline-analysis.cc: ...here. * ipa-inline-transform.c: Moved to... * ipa-inline-transform.cc: ...here. * ipa-inline.c: Moved to... * ipa-inline.cc: ...here. * ipa-modref-tree.c: Moved to... * ipa-modref-tree.cc: ...here. * ipa-modref.c: Moved to... * ipa-modref.cc: ...here. * ipa-param-manipulation.c: Moved to... * ipa-param-manipulation.cc: ...here. * ipa-polymorphic-call.c: Moved to... * ipa-polymorphic-call.cc: ...here. * ipa-predicate.c: Moved to... * ipa-predicate.cc: ...here. * ipa-profile.c: Moved to... * ipa-profile.cc: ...here. * ipa-prop.c: Moved to... * ipa-prop.cc: ...here. * ipa-pure-const.c: Moved to... * ipa-pure-const.cc: ...here. * ipa-ref.c: Moved to... * ipa-ref.cc: ...here. * ipa-reference.c: Moved to... * ipa-reference.cc: ...here. * ipa-split.c: Moved to... * ipa-split.cc: ...here. * ipa-sra.c: Moved to... * ipa-sra.cc: ...here. * ipa-utils.c: Moved to... * ipa-utils.cc: ...here. * ipa-visibility.c: Moved to... * ipa-visibility.cc: ...here. * ipa.c: Moved to... * ipa.cc: ...here. * ira-build.c: Moved to... * ira-build.cc: ...here. * ira-color.c: Moved to... * ira-color.cc: ...here. * ira-conflicts.c: Moved to... * ira-conflicts.cc: ...here. * ira-costs.c: Moved to... * ira-costs.cc: ...here. * ira-emit.c: Moved to... * ira-emit.cc: ...here. * ira-lives.c: Moved to... * ira-lives.cc: ...here. * ira.c: Moved to... * ira.cc: ...here. * jump.c: Moved to... * jump.cc: ...here. * langhooks.c: Moved to... * langhooks.cc: ...here. * lcm.c: Moved to... * lcm.cc: ...here. * lists.c: Moved to... * lists.cc: ...here. * loop-doloop.c: Moved to... * loop-doloop.cc: ...here. * loop-init.c: Moved to... * loop-init.cc: ...here. * loop-invariant.c: Moved to... * loop-invariant.cc: ...here. * loop-iv.c: Moved to... * loop-iv.cc: ...here. * loop-unroll.c: Moved to... * loop-unroll.cc: ...here. * lower-subreg.c: Moved to... * lower-subreg.cc: ...here. * lra-assigns.c: Moved to... * lra-assigns.cc: ...here. * lra-coalesce.c: Moved to... * lra-coalesce.cc: ...here. * lra-constraints.c: Moved to... * lra-constraints.cc: ...here. * lra-eliminations.c: Moved to... * lra-eliminations.cc: ...here. * lra-lives.c: Moved to... * lra-lives.cc: ...here. * lra-remat.c: Moved to... * lra-remat.cc: ...here. * lra-spills.c: Moved to... * lra-spills.cc: ...here. * lra.c: Moved to... * lra.cc: ...here. * lto-cgraph.c: Moved to... * lto-cgraph.cc: ...here. * lto-compress.c: Moved to... * lto-compress.cc: ...here. * lto-opts.c: Moved to... * lto-opts.cc: ...here. * lto-section-in.c: Moved to... * lto-section-in.cc: ...here. * lto-section-out.c: Moved to... * lto-section-out.cc: ...here. * lto-streamer-in.c: Moved to... * lto-streamer-in.cc: ...here. * lto-streamer-out.c: Moved to... * lto-streamer-out.cc: ...here. * lto-streamer.c: Moved to... * lto-streamer.cc: ...here. * lto-wrapper.c: Moved to... * lto-wrapper.cc: ...here. * main.c: Moved to... * main.cc: ...here. * mcf.c: Moved to... * mcf.cc: ...here. * mode-switching.c: Moved to... * mode-switching.cc: ...here. * modulo-sched.c: Moved to... * modulo-sched.cc: ...here. * multiple_target.c: Moved to... * multiple_target.cc: ...here. * omp-expand.c: Moved to... * omp-expand.cc: ...here. * omp-general.c: Moved to... * omp-general.cc: ...here. * omp-low.c: Moved to... * omp-low.cc: ...here. * omp-offload.c: Moved to... * omp-offload.cc: ...here. * omp-simd-clone.c: Moved to... * omp-simd-clone.cc: ...here. * opt-suggestions.c: Moved to... * opt-suggestions.cc: ...here. * optabs-libfuncs.c: Moved to... * optabs-libfuncs.cc: ...here. * optabs-query.c: Moved to... * optabs-query.cc: ...here. * optabs-tree.c: Moved to... * optabs-tree.cc: ...here. * optabs.c: Moved to... * optabs.cc: ...here. * opts-common.c: Moved to... * opts-common.cc: ...here. * opts-global.c: Moved to... * opts-global.cc: ...here. * opts.c: Moved to... * opts.cc: ...here. * passes.c: Moved to... * passes.cc: ...here. * plugin.c: Moved to... * plugin.cc: ...here. * postreload-gcse.c: Moved to... * postreload-gcse.cc: ...here. * postreload.c: Moved to... * postreload.cc: ...here. * predict.c: Moved to... * predict.cc: ...here. * prefix.c: Moved to... * prefix.cc: ...here. * pretty-print.c: Moved to... * pretty-print.cc: ...here. * print-rtl-function.c: Moved to... * print-rtl-function.cc: ...here. * print-rtl.c: Moved to... * print-rtl.cc: ...here. * print-tree.c: Moved to... * print-tree.cc: ...here. * profile-count.c: Moved to... * profile-count.cc: ...here. * profile.c: Moved to... * profile.cc: ...here. * read-md.c: Moved to... * read-md.cc: ...here. * read-rtl-function.c: Moved to... * read-rtl-function.cc: ...here. * read-rtl.c: Moved to... * read-rtl.cc: ...here. * real.c: Moved to... * real.cc: ...here. * realmpfr.c: Moved to... * realmpfr.cc: ...here. * recog.c: Moved to... * recog.cc: ...here. * ree.c: Moved to... * ree.cc: ...here. * reg-stack.c: Moved to... * reg-stack.cc: ...here. * regcprop.c: Moved to... * regcprop.cc: ...here. * reginfo.c: Moved to... * reginfo.cc: ...here. * regrename.c: Moved to... * regrename.cc: ...here. * regstat.c: Moved to... * regstat.cc: ...here. * reload.c: Moved to... * reload.cc: ...here. * reload1.c: Moved to... * reload1.cc: ...here. * reorg.c: Moved to... * reorg.cc: ...here. * resource.c: Moved to... * resource.cc: ...here. * rtl-error.c: Moved to... * rtl-error.cc: ...here. * rtl-tests.c: Moved to... * rtl-tests.cc: ...here. * rtl.c: Moved to... * rtl.cc: ...here. * rtlanal.c: Moved to... * rtlanal.cc: ...here. * rtlhash.c: Moved to... * rtlhash.cc: ...here. * rtlhooks.c: Moved to... * rtlhooks.cc: ...here. * rtx-vector-builder.c: Moved to... * rtx-vector-builder.cc: ...here. * run-rtl-passes.c: Moved to... * run-rtl-passes.cc: ...here. * sancov.c: Moved to... * sancov.cc: ...here. * sanopt.c: Moved to... * sanopt.cc: ...here. * sbitmap.c: Moved to... * sbitmap.cc: ...here. * sched-deps.c: Moved to... * sched-deps.cc: ...here. * sched-ebb.c: Moved to... * sched-ebb.cc: ...here. * sched-rgn.c: Moved to... * sched-rgn.cc: ...here. * sel-sched-dump.c: Moved to... * sel-sched-dump.cc: ...here. * sel-sched-ir.c: Moved to... * sel-sched-ir.cc: ...here. * sel-sched.c: Moved to... * sel-sched.cc: ...here. * selftest-diagnostic.c: Moved to... * selftest-diagnostic.cc: ...here. * selftest-rtl.c: Moved to... * selftest-rtl.cc: ...here. * selftest-run-tests.c: Moved to... * selftest-run-tests.cc: ...here. * selftest.c: Moved to... * selftest.cc: ...here. * sese.c: Moved to... * sese.cc: ...here. * shrink-wrap.c: Moved to... * shrink-wrap.cc: ...here. * simplify-rtx.c: Moved to... * simplify-rtx.cc: ...here. * sparseset.c: Moved to... * sparseset.cc: ...here. * spellcheck-tree.c: Moved to... * spellcheck-tree.cc: ...here. * spellcheck.c: Moved to... * spellcheck.cc: ...here. * sreal.c: Moved to... * sreal.cc: ...here. * stack-ptr-mod.c: Moved to... * stack-ptr-mod.cc: ...here. * statistics.c: Moved to... * statistics.cc: ...here. * stmt.c: Moved to... * stmt.cc: ...here. * stor-layout.c: Moved to... * stor-layout.cc: ...here. * store-motion.c: Moved to... * store-motion.cc: ...here. * streamer-hooks.c: Moved to... * streamer-hooks.cc: ...here. * stringpool.c: Moved to... * stringpool.cc: ...here. * substring-locations.c: Moved to... * substring-locations.cc: ...here. * symtab.c: Moved to... * symtab.cc: ...here. * target-globals.c: Moved to... * target-globals.cc: ...here. * targhooks.c: Moved to... * targhooks.cc: ...here. * timevar.c: Moved to... * timevar.cc: ...here. * toplev.c: Moved to... * toplev.cc: ...here. * tracer.c: Moved to... * tracer.cc: ...here. * trans-mem.c: Moved to... * trans-mem.cc: ...here. * tree-affine.c: Moved to... * tree-affine.cc: ...here. * tree-call-cdce.c: Moved to... * tree-call-cdce.cc: ...here. * tree-cfg.c: Moved to... * tree-cfg.cc: ...here. * tree-cfgcleanup.c: Moved to... * tree-cfgcleanup.cc: ...here. * tree-chrec.c: Moved to... * tree-chrec.cc: ...here. * tree-complex.c: Moved to... * tree-complex.cc: ...here. * tree-data-ref.c: Moved to... * tree-data-ref.cc: ...here. * tree-dfa.c: Moved to... * tree-dfa.cc: ...here. * tree-diagnostic.c: Moved to... * tree-diagnostic.cc: ...here. * tree-dump.c: Moved to... * tree-dump.cc: ...here. * tree-eh.c: Moved to... * tree-eh.cc: ...here. * tree-emutls.c: Moved to... * tree-emutls.cc: ...here. * tree-if-conv.c: Moved to... * tree-if-conv.cc: ...here. * tree-inline.c: Moved to... * tree-inline.cc: ...here. * tree-into-ssa.c: Moved to... * tree-into-ssa.cc: ...here. * tree-iterator.c: Moved to... * tree-iterator.cc: ...here. * tree-loop-distribution.c: Moved to... * tree-loop-distribution.cc: ...here. * tree-nested.c: Moved to... * tree-nested.cc: ...here. * tree-nrv.c: Moved to... * tree-nrv.cc: ...here. * tree-object-size.c: Moved to... * tree-object-size.cc: ...here. * tree-outof-ssa.c: Moved to... * tree-outof-ssa.cc: ...here. * tree-parloops.c: Moved to... * tree-parloops.cc: ...here. * tree-phinodes.c: Moved to... * tree-phinodes.cc: ...here. * tree-predcom.c: Moved to... * tree-predcom.cc: ...here. * tree-pretty-print.c: Moved to... * tree-pretty-print.cc: ...here. * tree-profile.c: Moved to... * tree-profile.cc: ...here. * tree-scalar-evolution.c: Moved to... * tree-scalar-evolution.cc: ...here. * tree-sra.c: Moved to... * tree-sra.cc: ...here. * tree-ssa-address.c: Moved to... * tree-ssa-address.cc: ...here. * tree-ssa-alias.c: Moved to... * tree-ssa-alias.cc: ...here. * tree-ssa-ccp.c: Moved to... * tree-ssa-ccp.cc: ...here. * tree-ssa-coalesce.c: Moved to... * tree-ssa-coalesce.cc: ...here. * tree-ssa-copy.c: Moved to... * tree-ssa-copy.cc: ...here. * tree-ssa-dce.c: Moved to... * tree-ssa-dce.cc: ...here. * tree-ssa-dom.c: Moved to... * tree-ssa-dom.cc: ...here. * tree-ssa-dse.c: Moved to... * tree-ssa-dse.cc: ...here. * tree-ssa-forwprop.c: Moved to... * tree-ssa-forwprop.cc: ...here. * tree-ssa-ifcombine.c: Moved to... * tree-ssa-ifcombine.cc: ...here. * tree-ssa-live.c: Moved to... * tree-ssa-live.cc: ...here. * tree-ssa-loop-ch.c: Moved to... * tree-ssa-loop-ch.cc: ...here. * tree-ssa-loop-im.c: Moved to... * tree-ssa-loop-im.cc: ...here. * tree-ssa-loop-ivcanon.c: Moved to... * tree-ssa-loop-ivcanon.cc: ...here. * tree-ssa-loop-ivopts.c: Moved to... * tree-ssa-loop-ivopts.cc: ...here. * tree-ssa-loop-manip.c: Moved to... * tree-ssa-loop-manip.cc: ...here. * tree-ssa-loop-niter.c: Moved to... * tree-ssa-loop-niter.cc: ...here. * tree-ssa-loop-prefetch.c: Moved to... * tree-ssa-loop-prefetch.cc: ...here. * tree-ssa-loop-split.c: Moved to... * tree-ssa-loop-split.cc: ...here. * tree-ssa-loop-unswitch.c: Moved to... * tree-ssa-loop-unswitch.cc: ...here. * tree-ssa-loop.c: Moved to... * tree-ssa-loop.cc: ...here. * tree-ssa-math-opts.c: Moved to... * tree-ssa-math-opts.cc: ...here. * tree-ssa-operands.c: Moved to... * tree-ssa-operands.cc: ...here. * tree-ssa-phiopt.c: Moved to... * tree-ssa-phiopt.cc: ...here. * tree-ssa-phiprop.c: Moved to... * tree-ssa-phiprop.cc: ...here. * tree-ssa-pre.c: Moved to... * tree-ssa-pre.cc: ...here. * tree-ssa-propagate.c: Moved to... * tree-ssa-propagate.cc: ...here. * tree-ssa-reassoc.c: Moved to... * tree-ssa-reassoc.cc: ...here. * tree-ssa-sccvn.c: Moved to... * tree-ssa-sccvn.cc: ...here. * tree-ssa-scopedtables.c: Moved to... * tree-ssa-scopedtables.cc: ...here. * tree-ssa-sink.c: Moved to... * tree-ssa-sink.cc: ...here. * tree-ssa-strlen.c: Moved to... * tree-ssa-strlen.cc: ...here. * tree-ssa-structalias.c: Moved to... * tree-ssa-structalias.cc: ...here. * tree-ssa-tail-merge.c: Moved to... * tree-ssa-tail-merge.cc: ...here. * tree-ssa-ter.c: Moved to... * tree-ssa-ter.cc: ...here. * tree-ssa-threadbackward.c: Moved to... * tree-ssa-threadbackward.cc: ...here. * tree-ssa-threadedge.c: Moved to... * tree-ssa-threadedge.cc: ...here. * tree-ssa-threadupdate.c: Moved to... * tree-ssa-threadupdate.cc: ...here. * tree-ssa-uncprop.c: Moved to... * tree-ssa-uncprop.cc: ...here. * tree-ssa-uninit.c: Moved to... * tree-ssa-uninit.cc: ...here. * tree-ssa.c: Moved to... * tree-ssa.cc: ...here. * tree-ssanames.c: Moved to... * tree-ssanames.cc: ...here. * tree-stdarg.c: Moved to... * tree-stdarg.cc: ...here. * tree-streamer-in.c: Moved to... * tree-streamer-in.cc: ...here. * tree-streamer-out.c: Moved to... * tree-streamer-out.cc: ...here. * tree-streamer.c: Moved to... * tree-streamer.cc: ...here. * tree-switch-conversion.c: Moved to... * tree-switch-conversion.cc: ...here. * tree-tailcall.c: Moved to... * tree-tailcall.cc: ...here. * tree-vect-data-refs.c: Moved to... * tree-vect-data-refs.cc: ...here. * tree-vect-generic.c: Moved to... * tree-vect-generic.cc: ...here. * tree-vect-loop-manip.c: Moved to... * tree-vect-loop-manip.cc: ...here. * tree-vect-loop.c: Moved to... * tree-vect-loop.cc: ...here. * tree-vect-patterns.c: Moved to... * tree-vect-patterns.cc: ...here. * tree-vect-slp-patterns.c: Moved to... * tree-vect-slp-patterns.cc: ...here. * tree-vect-slp.c: Moved to... * tree-vect-slp.cc: ...here. * tree-vect-stmts.c: Moved to... * tree-vect-stmts.cc: ...here. * tree-vector-builder.c: Moved to... * tree-vector-builder.cc: ...here. * tree-vectorizer.c: Moved to... * tree-vectorizer.cc: ...here. * tree-vrp.c: Moved to... * tree-vrp.cc: ...here. * tree.c: Moved to... * tree.cc: ...here. * tsan.c: Moved to... * tsan.cc: ...here. * typed-splay-tree.c: Moved to... * typed-splay-tree.cc: ...here. * ubsan.c: Moved to... * ubsan.cc: ...here. * valtrack.c: Moved to... * valtrack.cc: ...here. * value-prof.c: Moved to... * value-prof.cc: ...here. * var-tracking.c: Moved to... * var-tracking.cc: ...here. * varasm.c: Moved to... * varasm.cc: ...here. * varpool.c: Moved to... * varpool.cc: ...here. * vec-perm-indices.c: Moved to... * vec-perm-indices.cc: ...here. * vec.c: Moved to... * vec.cc: ...here. * vmsdbgout.c: Moved to... * vmsdbgout.cc: ...here. * vr-values.c: Moved to... * vr-values.cc: ...here. * vtable-verify.c: Moved to... * vtable-verify.cc: ...here. * web.c: Moved to... * web.cc: ...here. * xcoffout.c: Moved to... * xcoffout.cc: ...here. gcc/c-family/ChangeLog: * c-ada-spec.c: Moved to... * c-ada-spec.cc: ...here. * c-attribs.c: Moved to... * c-attribs.cc: ...here. * c-common.c: Moved to... * c-common.cc: ...here. * c-cppbuiltin.c: Moved to... * c-cppbuiltin.cc: ...here. * c-dump.c: Moved to... * c-dump.cc: ...here. * c-format.c: Moved to... * c-format.cc: ...here. * c-gimplify.c: Moved to... * c-gimplify.cc: ...here. * c-indentation.c: Moved to... * c-indentation.cc: ...here. * c-lex.c: Moved to... * c-lex.cc: ...here. * c-omp.c: Moved to... * c-omp.cc: ...here. * c-opts.c: Moved to... * c-opts.cc: ...here. * c-pch.c: Moved to... * c-pch.cc: ...here. * c-ppoutput.c: Moved to... * c-ppoutput.cc: ...here. * c-pragma.c: Moved to... * c-pragma.cc: ...here. * c-pretty-print.c: Moved to... * c-pretty-print.cc: ...here. * c-semantics.c: Moved to... * c-semantics.cc: ...here. * c-ubsan.c: Moved to... * c-ubsan.cc: ...here. * c-warn.c: Moved to... * c-warn.cc: ...here. * cppspec.c: Moved to... * cppspec.cc: ...here. * stub-objc.c: Moved to... * stub-objc.cc: ...here. gcc/c/ChangeLog: * c-aux-info.c: Moved to... * c-aux-info.cc: ...here. * c-convert.c: Moved to... * c-convert.cc: ...here. * c-decl.c: Moved to... * c-decl.cc: ...here. * c-errors.c: Moved to... * c-errors.cc: ...here. * c-fold.c: Moved to... * c-fold.cc: ...here. * c-lang.c: Moved to... * c-lang.cc: ...here. * c-objc-common.c: Moved to... * c-objc-common.cc: ...here. * c-parser.c: Moved to... * c-parser.cc: ...here. * c-typeck.c: Moved to... * c-typeck.cc: ...here. * gccspec.c: Moved to... * gccspec.cc: ...here. * gimple-parser.c: Moved to... * gimple-parser.cc: ...here. gcc/cp/ChangeLog: * call.c: Moved to... * call.cc: ...here. * class.c: Moved to... * class.cc: ...here. * constexpr.c: Moved to... * constexpr.cc: ...here. * cp-gimplify.c: Moved to... * cp-gimplify.cc: ...here. * cp-lang.c: Moved to... * cp-lang.cc: ...here. * cp-objcp-common.c: Moved to... * cp-objcp-common.cc: ...here. * cp-ubsan.c: Moved to... * cp-ubsan.cc: ...here. * cvt.c: Moved to... * cvt.cc: ...here. * cxx-pretty-print.c: Moved to... * cxx-pretty-print.cc: ...here. * decl.c: Moved to... * decl.cc: ...here. * decl2.c: Moved to... * decl2.cc: ...here. * dump.c: Moved to... * dump.cc: ...here. * error.c: Moved to... * error.cc: ...here. * except.c: Moved to... * except.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * friend.c: Moved to... * friend.cc: ...here. * g++spec.c: Moved to... * g++spec.cc: ...here. * init.c: Moved to... * init.cc: ...here. * lambda.c: Moved to... * lambda.cc: ...here. * lex.c: Moved to... * lex.cc: ...here. * mangle.c: Moved to... * mangle.cc: ...here. * method.c: Moved to... * method.cc: ...here. * name-lookup.c: Moved to... * name-lookup.cc: ...here. * optimize.c: Moved to... * optimize.cc: ...here. * parser.c: Moved to... * parser.cc: ...here. * pt.c: Moved to... * pt.cc: ...here. * ptree.c: Moved to... * ptree.cc: ...here. * rtti.c: Moved to... * rtti.cc: ...here. * search.c: Moved to... * search.cc: ...here. * semantics.c: Moved to... * semantics.cc: ...here. * tree.c: Moved to... * tree.cc: ...here. * typeck.c: Moved to... * typeck.cc: ...here. * typeck2.c: Moved to... * typeck2.cc: ...here. * vtable-class-hierarchy.c: Moved to... * vtable-class-hierarchy.cc: ...here. gcc/fortran/ChangeLog: * arith.c: Moved to... * arith.cc: ...here. * array.c: Moved to... * array.cc: ...here. * bbt.c: Moved to... * bbt.cc: ...here. * check.c: Moved to... * check.cc: ...here. * class.c: Moved to... * class.cc: ...here. * constructor.c: Moved to... * constructor.cc: ...here. * convert.c: Moved to... * convert.cc: ...here. * cpp.c: Moved to... * cpp.cc: ...here. * data.c: Moved to... * data.cc: ...here. * decl.c: Moved to... * decl.cc: ...here. * dependency.c: Moved to... * dependency.cc: ...here. * dump-parse-tree.c: Moved to... * dump-parse-tree.cc: ...here. * error.c: Moved to... * error.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * f95-lang.c: Moved to... * f95-lang.cc: ...here. * frontend-passes.c: Moved to... * frontend-passes.cc: ...here. * gfortranspec.c: Moved to... * gfortranspec.cc: ...here. * interface.c: Moved to... * interface.cc: ...here. * intrinsic.c: Moved to... * intrinsic.cc: ...here. * io.c: Moved to... * io.cc: ...here. * iresolve.c: Moved to... * iresolve.cc: ...here. * match.c: Moved to... * match.cc: ...here. * matchexp.c: Moved to... * matchexp.cc: ...here. * misc.c: Moved to... * misc.cc: ...here. * module.c: Moved to... * module.cc: ...here. * openmp.c: Moved to... * openmp.cc: ...here. * options.c: Moved to... * options.cc: ...here. * parse.c: Moved to... * parse.cc: ...here. * primary.c: Moved to... * primary.cc: ...here. * resolve.c: Moved to... * resolve.cc: ...here. * scanner.c: Moved to... * scanner.cc: ...here. * simplify.c: Moved to... * simplify.cc: ...here. * st.c: Moved to... * st.cc: ...here. * symbol.c: Moved to... * symbol.cc: ...here. * target-memory.c: Moved to... * target-memory.cc: ...here. * trans-array.c: Moved to... * trans-array.cc: ...here. * trans-common.c: Moved to... * trans-common.cc: ...here. * trans-const.c: Moved to... * trans-const.cc: ...here. * trans-decl.c: Moved to... * trans-decl.cc: ...here. * trans-expr.c: Moved to... * trans-expr.cc: ...here. * trans-intrinsic.c: Moved to... * trans-intrinsic.cc: ...here. * trans-io.c: Moved to... * trans-io.cc: ...here. * trans-openmp.c: Moved to... * trans-openmp.cc: ...here. * trans-stmt.c: Moved to... * trans-stmt.cc: ...here. * trans-types.c: Moved to... * trans-types.cc: ...here. * trans.c: Moved to... * trans.cc: ...here. gcc/go/ChangeLog: * go-backend.c: Moved to... * go-backend.cc: ...here. * go-lang.c: Moved to... * go-lang.cc: ...here. * gospec.c: Moved to... * gospec.cc: ...here. gcc/jit/ChangeLog: * dummy-frontend.c: Moved to... * dummy-frontend.cc: ...here. * jit-builtins.c: Moved to... * jit-builtins.cc: ...here. * jit-logging.c: Moved to... * jit-logging.cc: ...here. * jit-playback.c: Moved to... * jit-playback.cc: ...here. * jit-recording.c: Moved to... * jit-recording.cc: ...here. * jit-result.c: Moved to... * jit-result.cc: ...here. * jit-spec.c: Moved to... * jit-spec.cc: ...here. * jit-tempdir.c: Moved to... * jit-tempdir.cc: ...here. * jit-w32.c: Moved to... * jit-w32.cc: ...here. * libgccjit.c: Moved to... * libgccjit.cc: ...here. gcc/lto/ChangeLog: * common.c: Moved to... * common.cc: ...here. * lto-common.c: Moved to... * lto-common.cc: ...here. * lto-dump.c: Moved to... * lto-dump.cc: ...here. * lto-lang.c: Moved to... * lto-lang.cc: ...here. * lto-object.c: Moved to... * lto-object.cc: ...here. * lto-partition.c: Moved to... * lto-partition.cc: ...here. * lto-symtab.c: Moved to... * lto-symtab.cc: ...here. * lto.c: Moved to... * lto.cc: ...here. gcc/objc/ChangeLog: * objc-act.c: Moved to... * objc-act.cc: ...here. * objc-encoding.c: Moved to... * objc-encoding.cc: ...here. * objc-gnu-runtime-abi-01.c: Moved to... * objc-gnu-runtime-abi-01.cc: ...here. * objc-lang.c: Moved to... * objc-lang.cc: ...here. * objc-map.c: Moved to... * objc-map.cc: ...here. * objc-next-runtime-abi-01.c: Moved to... * objc-next-runtime-abi-01.cc: ...here. * objc-next-runtime-abi-02.c: Moved to... * objc-next-runtime-abi-02.cc: ...here. * objc-runtime-shared-support.c: Moved to... * objc-runtime-shared-support.cc: ...here. gcc/objcp/ChangeLog: * objcp-decl.c: Moved to... * objcp-decl.cc: ...here. * objcp-lang.c: Moved to... * objcp-lang.cc: ...here. libcpp/ChangeLog: * charset.c: Moved to... * charset.cc: ...here. * directives.c: Moved to... * directives.cc: ...here. * errors.c: Moved to... * errors.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * files.c: Moved to... * files.cc: ...here. * identifiers.c: Moved to... * identifiers.cc: ...here. * init.c: Moved to... * init.cc: ...here. * lex.c: Moved to... * lex.cc: ...here. * line-map.c: Moved to... * line-map.cc: ...here. * macro.c: Moved to... * macro.cc: ...here. * makeucnid.c: Moved to... * makeucnid.cc: ...here. * mkdeps.c: Moved to... * mkdeps.cc: ...here. * pch.c: Moved to... * pch.cc: ...here. * symtab.c: Moved to... * symtab.cc: ...here. * traditional.c: Moved to... * traditional.cc: ...here.
Diffstat (limited to 'gcc/fortran/openmp.cc')
-rw-r--r--gcc/fortran/openmp.cc9411
1 files changed, 9411 insertions, 0 deletions
diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
new file mode 100644
index 0000000..4a03197
--- /dev/null
+++ b/gcc/fortran/openmp.cc
@@ -0,0 +1,9411 @@
+/* OpenMP directive matching and resolving.
+ Copyright (C) 2005-2022 Free Software Foundation, Inc.
+ Contributed by Jakub Jelinek
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "gfortran.h"
+#include "arith.h"
+#include "match.h"
+#include "parse.h"
+#include "constructor.h"
+#include "diagnostic.h"
+#include "gomp-constants.h"
+#include "target-memory.h" /* For gfc_encode_character. */
+
+/* Match an end of OpenMP directive. End of OpenMP directive is optional
+ whitespace, followed by '\n' or comment '!'. */
+
+static match
+gfc_match_omp_eos (void)
+{
+ locus old_loc;
+ char c;
+
+ old_loc = gfc_current_locus;
+ gfc_gobble_whitespace ();
+
+ c = gfc_next_ascii_char ();
+ switch (c)
+ {
+ case '!':
+ do
+ c = gfc_next_ascii_char ();
+ while (c != '\n');
+ /* Fall through */
+
+ case '\n':
+ return MATCH_YES;
+ }
+
+ gfc_current_locus = old_loc;
+ return MATCH_NO;
+}
+
+match
+gfc_match_omp_eos_error (void)
+{
+ if (gfc_match_omp_eos() == MATCH_YES)
+ return MATCH_YES;
+
+ gfc_error ("Unexpected junk at %C");
+ return MATCH_ERROR;
+}
+
+
+/* Free an omp_clauses structure. */
+
+void
+gfc_free_omp_clauses (gfc_omp_clauses *c)
+{
+ int i;
+ if (c == NULL)
+ return;
+
+ gfc_free_expr (c->if_expr);
+ gfc_free_expr (c->final_expr);
+ gfc_free_expr (c->num_threads);
+ gfc_free_expr (c->chunk_size);
+ gfc_free_expr (c->safelen_expr);
+ gfc_free_expr (c->simdlen_expr);
+ gfc_free_expr (c->num_teams_lower);
+ gfc_free_expr (c->num_teams_upper);
+ gfc_free_expr (c->device);
+ gfc_free_expr (c->thread_limit);
+ gfc_free_expr (c->dist_chunk_size);
+ gfc_free_expr (c->grainsize);
+ gfc_free_expr (c->hint);
+ gfc_free_expr (c->num_tasks);
+ gfc_free_expr (c->priority);
+ gfc_free_expr (c->detach);
+ for (i = 0; i < OMP_IF_LAST; i++)
+ gfc_free_expr (c->if_exprs[i]);
+ gfc_free_expr (c->async_expr);
+ gfc_free_expr (c->gang_num_expr);
+ gfc_free_expr (c->gang_static_expr);
+ gfc_free_expr (c->worker_expr);
+ gfc_free_expr (c->vector_expr);
+ gfc_free_expr (c->num_gangs_expr);
+ gfc_free_expr (c->num_workers_expr);
+ gfc_free_expr (c->vector_length_expr);
+ for (i = 0; i < OMP_LIST_NUM; i++)
+ gfc_free_omp_namelist (c->lists[i],
+ i == OMP_LIST_AFFINITY || i == OMP_LIST_DEPEND);
+ gfc_free_expr_list (c->wait_list);
+ gfc_free_expr_list (c->tile_list);
+ free (CONST_CAST (char *, c->critical_name));
+ free (c);
+}
+
+/* Free oacc_declare structures. */
+
+void
+gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *oc)
+{
+ struct gfc_oacc_declare *decl = oc;
+
+ do
+ {
+ struct gfc_oacc_declare *next;
+
+ next = decl->next;
+ gfc_free_omp_clauses (decl->clauses);
+ free (decl);
+ decl = next;
+ }
+ while (decl);
+}
+
+/* Free expression list. */
+void
+gfc_free_expr_list (gfc_expr_list *list)
+{
+ gfc_expr_list *n;
+
+ for (; list; list = n)
+ {
+ n = list->next;
+ free (list);
+ }
+}
+
+/* Free an !$omp declare simd construct list. */
+
+void
+gfc_free_omp_declare_simd (gfc_omp_declare_simd *ods)
+{
+ if (ods)
+ {
+ gfc_free_omp_clauses (ods->clauses);
+ free (ods);
+ }
+}
+
+void
+gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
+{
+ while (list)
+ {
+ gfc_omp_declare_simd *current = list;
+ list = list->next;
+ gfc_free_omp_declare_simd (current);
+ }
+}
+
+static void
+gfc_free_omp_trait_property_list (gfc_omp_trait_property *list)
+{
+ while (list)
+ {
+ gfc_omp_trait_property *current = list;
+ list = list->next;
+ switch (current->property_kind)
+ {
+ case CTX_PROPERTY_ID:
+ free (current->name);
+ break;
+ case CTX_PROPERTY_NAME_LIST:
+ if (current->is_name)
+ free (current->name);
+ break;
+ case CTX_PROPERTY_SIMD:
+ gfc_free_omp_clauses (current->clauses);
+ break;
+ default:
+ break;
+ }
+ free (current);
+ }
+}
+
+static void
+gfc_free_omp_selector_list (gfc_omp_selector *list)
+{
+ while (list)
+ {
+ gfc_omp_selector *current = list;
+ list = list->next;
+ gfc_free_omp_trait_property_list (current->properties);
+ free (current);
+ }
+}
+
+static void
+gfc_free_omp_set_selector_list (gfc_omp_set_selector *list)
+{
+ while (list)
+ {
+ gfc_omp_set_selector *current = list;
+ list = list->next;
+ gfc_free_omp_selector_list (current->trait_selectors);
+ free (current);
+ }
+}
+
+/* Free an !$omp declare variant construct list. */
+
+void
+gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list)
+{
+ while (list)
+ {
+ gfc_omp_declare_variant *current = list;
+ list = list->next;
+ gfc_free_omp_set_selector_list (current->set_selectors);
+ free (current);
+ }
+}
+
+/* Free an !$omp declare reduction. */
+
+void
+gfc_free_omp_udr (gfc_omp_udr *omp_udr)
+{
+ if (omp_udr)
+ {
+ gfc_free_omp_udr (omp_udr->next);
+ gfc_free_namespace (omp_udr->combiner_ns);
+ if (omp_udr->initializer_ns)
+ gfc_free_namespace (omp_udr->initializer_ns);
+ free (omp_udr);
+ }
+}
+
+
+static gfc_omp_udr *
+gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts)
+{
+ gfc_symtree *st;
+
+ if (ns == NULL)
+ ns = gfc_current_ns;
+ do
+ {
+ gfc_omp_udr *omp_udr;
+
+ st = gfc_find_symtree (ns->omp_udr_root, name);
+ if (st != NULL)
+ {
+ for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
+ if (ts == NULL)
+ return omp_udr;
+ else if (gfc_compare_types (&omp_udr->ts, ts))
+ {
+ if (ts->type == BT_CHARACTER)
+ {
+ if (omp_udr->ts.u.cl->length == NULL)
+ return omp_udr;
+ if (ts->u.cl->length == NULL)
+ continue;
+ if (gfc_compare_expr (omp_udr->ts.u.cl->length,
+ ts->u.cl->length,
+ INTRINSIC_EQ) != 0)
+ continue;
+ }
+ return omp_udr;
+ }
+ }
+
+ /* Don't escape an interface block. */
+ if (ns && !ns->has_import_set
+ && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
+ break;
+
+ ns = ns->parent;
+ }
+ while (ns != NULL);
+
+ return NULL;
+}
+
+
+/* Match a variable/common block list and construct a namelist from it. */
+
+static match
+gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
+ bool allow_common, bool *end_colon = NULL,
+ gfc_omp_namelist ***headp = NULL,
+ bool allow_sections = false,
+ bool allow_derived = false)
+{
+ gfc_omp_namelist *head, *tail, *p;
+ locus old_loc, cur_loc;
+ char n[GFC_MAX_SYMBOL_LEN+1];
+ gfc_symbol *sym;
+ match m;
+ gfc_symtree *st;
+
+ head = tail = NULL;
+
+ old_loc = gfc_current_locus;
+
+ m = gfc_match (str);
+ if (m != MATCH_YES)
+ return m;
+
+ for (;;)
+ {
+ cur_loc = gfc_current_locus;
+ m = gfc_match_symbol (&sym, 1);
+ switch (m)
+ {
+ case MATCH_YES:
+ gfc_expr *expr;
+ expr = NULL;
+ gfc_gobble_whitespace ();
+ if ((allow_sections && gfc_peek_ascii_char () == '(')
+ || (allow_derived && gfc_peek_ascii_char () == '%'))
+ {
+ gfc_current_locus = cur_loc;
+ m = gfc_match_variable (&expr, 0);
+ switch (m)
+ {
+ case MATCH_ERROR:
+ goto cleanup;
+ case MATCH_NO:
+ goto syntax;
+ default:
+ break;
+ }
+ if (gfc_is_coindexed (expr))
+ {
+ gfc_error ("List item shall not be coindexed at %C");
+ goto cleanup;
+ }
+ }
+ gfc_set_sym_referenced (sym);
+ p = gfc_get_omp_namelist ();
+ if (head == NULL)
+ head = tail = p;
+ else
+ {
+ tail->next = p;
+ tail = tail->next;
+ }
+ tail->sym = sym;
+ tail->expr = expr;
+ tail->where = cur_loc;
+ goto next_item;
+ case MATCH_NO:
+ break;
+ case MATCH_ERROR:
+ goto cleanup;
+ }
+
+ if (!allow_common)
+ goto syntax;
+
+ m = gfc_match (" / %n /", n);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_NO)
+ goto syntax;
+
+ st = gfc_find_symtree (gfc_current_ns->common_root, n);
+ if (st == NULL)
+ {
+ gfc_error ("COMMON block /%s/ not found at %C", n);
+ goto cleanup;
+ }
+ for (sym = st->n.common->head; sym; sym = sym->common_next)
+ {
+ gfc_set_sym_referenced (sym);
+ p = gfc_get_omp_namelist ();
+ if (head == NULL)
+ head = tail = p;
+ else
+ {
+ tail->next = p;
+ tail = tail->next;
+ }
+ tail->sym = sym;
+ tail->where = cur_loc;
+ }
+
+ next_item:
+ if (end_colon && gfc_match_char (':') == MATCH_YES)
+ {
+ *end_colon = true;
+ break;
+ }
+ if (gfc_match_char (')') == MATCH_YES)
+ break;
+ if (gfc_match_char (',') != MATCH_YES)
+ goto syntax;
+ }
+
+ while (*list)
+ list = &(*list)->next;
+
+ *list = head;
+ if (headp)
+ *headp = list;
+ return MATCH_YES;
+
+syntax:
+ gfc_error ("Syntax error in OpenMP variable list at %C");
+
+cleanup:
+ gfc_free_omp_namelist (head, false);
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+}
+
+/* Match a variable/procedure/common block list and construct a namelist
+ from it. */
+
+static match
+gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list)
+{
+ gfc_omp_namelist *head, *tail, *p;
+ locus old_loc, cur_loc;
+ char n[GFC_MAX_SYMBOL_LEN+1];
+ gfc_symbol *sym;
+ match m;
+ gfc_symtree *st;
+
+ head = tail = NULL;
+
+ old_loc = gfc_current_locus;
+
+ m = gfc_match (str);
+ if (m != MATCH_YES)
+ return m;
+
+ for (;;)
+ {
+ cur_loc = gfc_current_locus;
+ m = gfc_match_symbol (&sym, 1);
+ switch (m)
+ {
+ case MATCH_YES:
+ p = gfc_get_omp_namelist ();
+ if (head == NULL)
+ head = tail = p;
+ else
+ {
+ tail->next = p;
+ tail = tail->next;
+ }
+ tail->sym = sym;
+ tail->where = cur_loc;
+ goto next_item;
+ case MATCH_NO:
+ break;
+ case MATCH_ERROR:
+ goto cleanup;
+ }
+
+ m = gfc_match (" / %n /", n);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_NO)
+ goto syntax;
+
+ st = gfc_find_symtree (gfc_current_ns->common_root, n);
+ if (st == NULL)
+ {
+ gfc_error ("COMMON block /%s/ not found at %C", n);
+ goto cleanup;
+ }
+ p = gfc_get_omp_namelist ();
+ if (head == NULL)
+ head = tail = p;
+ else
+ {
+ tail->next = p;
+ tail = tail->next;
+ }
+ tail->u.common = st->n.common;
+ tail->where = cur_loc;
+
+ next_item:
+ if (gfc_match_char (')') == MATCH_YES)
+ break;
+ if (gfc_match_char (',') != MATCH_YES)
+ goto syntax;
+ }
+
+ while (*list)
+ list = &(*list)->next;
+
+ *list = head;
+ return MATCH_YES;
+
+syntax:
+ gfc_error ("Syntax error in OpenMP variable list at %C");
+
+cleanup:
+ gfc_free_omp_namelist (head, false);
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+}
+
+/* Match detach(event-handle). */
+
+static match
+gfc_match_omp_detach (gfc_expr **expr)
+{
+ locus old_loc = gfc_current_locus;
+
+ if (gfc_match ("detach ( ") != MATCH_YES)
+ goto syntax_error;
+
+ if (gfc_match_variable (expr, 0) != MATCH_YES)
+ goto syntax_error;
+
+ if ((*expr)->ts.type != BT_INTEGER || (*expr)->ts.kind != gfc_c_intptr_kind)
+ {
+ gfc_error ("%qs at %L should be of type "
+ "integer(kind=omp_event_handle_kind)",
+ (*expr)->symtree->n.sym->name, &(*expr)->where);
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match_char (')') != MATCH_YES)
+ goto syntax_error;
+
+ return MATCH_YES;
+
+syntax_error:
+ gfc_error ("Syntax error in OpenMP detach clause at %C");
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+
+}
+
+/* Match depend(sink : ...) construct a namelist from it. */
+
+static match
+gfc_match_omp_depend_sink (gfc_omp_namelist **list)
+{
+ gfc_omp_namelist *head, *tail, *p;
+ locus old_loc, cur_loc;
+ gfc_symbol *sym;
+
+ head = tail = NULL;
+
+ old_loc = gfc_current_locus;
+
+ for (;;)
+ {
+ cur_loc = gfc_current_locus;
+ switch (gfc_match_symbol (&sym, 1))
+ {
+ case MATCH_YES:
+ gfc_set_sym_referenced (sym);
+ p = gfc_get_omp_namelist ();
+ if (head == NULL)
+ {
+ head = tail = p;
+ head->u.depend_op = OMP_DEPEND_SINK_FIRST;
+ }
+ else
+ {
+ tail->next = p;
+ tail = tail->next;
+ tail->u.depend_op = OMP_DEPEND_SINK;
+ }
+ tail->sym = sym;
+ tail->expr = NULL;
+ tail->where = cur_loc;
+ if (gfc_match_char ('+') == MATCH_YES)
+ {
+ if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
+ goto syntax;
+ }
+ else if (gfc_match_char ('-') == MATCH_YES)
+ {
+ if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
+ goto syntax;
+ tail->expr = gfc_uminus (tail->expr);
+ }
+ break;
+ case MATCH_NO:
+ goto syntax;
+ case MATCH_ERROR:
+ goto cleanup;
+ }
+
+ if (gfc_match_char (')') == MATCH_YES)
+ break;
+ if (gfc_match_char (',') != MATCH_YES)
+ goto syntax;
+ }
+
+ while (*list)
+ list = &(*list)->next;
+
+ *list = head;
+ return MATCH_YES;
+
+syntax:
+ gfc_error ("Syntax error in OpenMP DEPEND SINK list at %C");
+
+cleanup:
+ gfc_free_omp_namelist (head, false);
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+}
+
+static match
+match_oacc_expr_list (const char *str, gfc_expr_list **list,
+ bool allow_asterisk)
+{
+ gfc_expr_list *head, *tail, *p;
+ locus old_loc;
+ gfc_expr *expr;
+ match m;
+
+ head = tail = NULL;
+
+ old_loc = gfc_current_locus;
+
+ m = gfc_match (str);
+ if (m != MATCH_YES)
+ return m;
+
+ for (;;)
+ {
+ m = gfc_match_expr (&expr);
+ if (m == MATCH_YES || allow_asterisk)
+ {
+ p = gfc_get_expr_list ();
+ if (head == NULL)
+ head = tail = p;
+ else
+ {
+ tail->next = p;
+ tail = tail->next;
+ }
+ if (m == MATCH_YES)
+ tail->expr = expr;
+ else if (gfc_match (" *") != MATCH_YES)
+ goto syntax;
+ goto next_item;
+ }
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ goto syntax;
+
+ next_item:
+ if (gfc_match_char (')') == MATCH_YES)
+ break;
+ if (gfc_match_char (',') != MATCH_YES)
+ goto syntax;
+ }
+
+ while (*list)
+ list = &(*list)->next;
+
+ *list = head;
+ return MATCH_YES;
+
+syntax:
+ gfc_error ("Syntax error in OpenACC expression list at %C");
+
+cleanup:
+ gfc_free_expr_list (head);
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+}
+
+static match
+match_oacc_clause_gwv (gfc_omp_clauses *cp, unsigned gwv)
+{
+ match ret = MATCH_YES;
+
+ if (gfc_match (" ( ") != MATCH_YES)
+ return MATCH_NO;
+
+ if (gwv == GOMP_DIM_GANG)
+ {
+ /* The gang clause accepts two optional arguments, num and static.
+ The num argument may either be explicit (num: <val>) or
+ implicit without (<val> without num:). */
+
+ while (ret == MATCH_YES)
+ {
+ if (gfc_match (" static :") == MATCH_YES)
+ {
+ if (cp->gang_static)
+ return MATCH_ERROR;
+ else
+ cp->gang_static = true;
+ if (gfc_match_char ('*') == MATCH_YES)
+ cp->gang_static_expr = NULL;
+ else if (gfc_match (" %e ", &cp->gang_static_expr) != MATCH_YES)
+ return MATCH_ERROR;
+ }
+ else
+ {
+ if (cp->gang_num_expr)
+ return MATCH_ERROR;
+
+ /* The 'num' argument is optional. */
+ gfc_match (" num :");
+
+ if (gfc_match (" %e ", &cp->gang_num_expr) != MATCH_YES)
+ return MATCH_ERROR;
+ }
+
+ ret = gfc_match (" , ");
+ }
+ }
+ else if (gwv == GOMP_DIM_WORKER)
+ {
+ /* The 'num' argument is optional. */
+ gfc_match (" num :");
+
+ if (gfc_match (" %e ", &cp->worker_expr) != MATCH_YES)
+ return MATCH_ERROR;
+ }
+ else if (gwv == GOMP_DIM_VECTOR)
+ {
+ /* The 'length' argument is optional. */
+ gfc_match (" length :");
+
+ if (gfc_match (" %e ", &cp->vector_expr) != MATCH_YES)
+ return MATCH_ERROR;
+ }
+ else
+ gfc_fatal_error ("Unexpected OpenACC parallelism.");
+
+ return gfc_match (" )");
+}
+
+static match
+gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list)
+{
+ gfc_omp_namelist *head = NULL;
+ gfc_omp_namelist *tail, *p;
+ locus old_loc;
+ char n[GFC_MAX_SYMBOL_LEN+1];
+ gfc_symbol *sym;
+ match m;
+ gfc_symtree *st;
+
+ old_loc = gfc_current_locus;
+
+ m = gfc_match (str);
+ if (m != MATCH_YES)
+ return m;
+
+ m = gfc_match (" (");
+
+ for (;;)
+ {
+ m = gfc_match_symbol (&sym, 0);
+ switch (m)
+ {
+ case MATCH_YES:
+ if (sym->attr.in_common)
+ {
+ gfc_error_now ("Variable at %C is an element of a COMMON block");
+ goto cleanup;
+ }
+ gfc_set_sym_referenced (sym);
+ p = gfc_get_omp_namelist ();
+ if (head == NULL)
+ head = tail = p;
+ else
+ {
+ tail->next = p;
+ tail = tail->next;
+ }
+ tail->sym = sym;
+ tail->expr = NULL;
+ tail->where = gfc_current_locus;
+ goto next_item;
+ case MATCH_NO:
+ break;
+
+ case MATCH_ERROR:
+ goto cleanup;
+ }
+
+ m = gfc_match (" / %n /", n);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_NO || n[0] == '\0')
+ goto syntax;
+
+ st = gfc_find_symtree (gfc_current_ns->common_root, n);
+ if (st == NULL)
+ {
+ gfc_error ("COMMON block /%s/ not found at %C", n);
+ goto cleanup;
+ }
+
+ for (sym = st->n.common->head; sym; sym = sym->common_next)
+ {
+ gfc_set_sym_referenced (sym);
+ p = gfc_get_omp_namelist ();
+ if (head == NULL)
+ head = tail = p;
+ else
+ {
+ tail->next = p;
+ tail = tail->next;
+ }
+ tail->sym = sym;
+ tail->where = gfc_current_locus;
+ }
+
+ next_item:
+ if (gfc_match_char (')') == MATCH_YES)
+ break;
+ if (gfc_match_char (',') != MATCH_YES)
+ goto syntax;
+ }
+
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after !$ACC DECLARE at %C");
+ goto cleanup;
+ }
+
+ while (*list)
+ list = &(*list)->next;
+ *list = head;
+ return MATCH_YES;
+
+syntax:
+ gfc_error ("Syntax error in !$ACC DECLARE list at %C");
+
+cleanup:
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+}
+
+/* OpenMP clauses. */
+enum omp_mask1
+{
+ OMP_CLAUSE_PRIVATE,
+ OMP_CLAUSE_FIRSTPRIVATE,
+ OMP_CLAUSE_LASTPRIVATE,
+ OMP_CLAUSE_COPYPRIVATE,
+ OMP_CLAUSE_SHARED,
+ OMP_CLAUSE_COPYIN,
+ OMP_CLAUSE_REDUCTION,
+ OMP_CLAUSE_IN_REDUCTION,
+ OMP_CLAUSE_TASK_REDUCTION,
+ OMP_CLAUSE_IF,
+ OMP_CLAUSE_NUM_THREADS,
+ OMP_CLAUSE_SCHEDULE,
+ OMP_CLAUSE_DEFAULT,
+ OMP_CLAUSE_ORDER,
+ OMP_CLAUSE_ORDERED,
+ OMP_CLAUSE_COLLAPSE,
+ OMP_CLAUSE_UNTIED,
+ OMP_CLAUSE_FINAL,
+ OMP_CLAUSE_MERGEABLE,
+ OMP_CLAUSE_ALIGNED,
+ OMP_CLAUSE_DEPEND,
+ OMP_CLAUSE_INBRANCH,
+ OMP_CLAUSE_LINEAR,
+ OMP_CLAUSE_NOTINBRANCH,
+ OMP_CLAUSE_PROC_BIND,
+ OMP_CLAUSE_SAFELEN,
+ OMP_CLAUSE_SIMDLEN,
+ OMP_CLAUSE_UNIFORM,
+ OMP_CLAUSE_DEVICE,
+ OMP_CLAUSE_MAP,
+ OMP_CLAUSE_TO,
+ OMP_CLAUSE_FROM,
+ OMP_CLAUSE_NUM_TEAMS,
+ OMP_CLAUSE_THREAD_LIMIT,
+ OMP_CLAUSE_DIST_SCHEDULE,
+ OMP_CLAUSE_DEFAULTMAP,
+ OMP_CLAUSE_GRAINSIZE,
+ OMP_CLAUSE_HINT,
+ OMP_CLAUSE_IS_DEVICE_PTR,
+ OMP_CLAUSE_LINK,
+ OMP_CLAUSE_NOGROUP,
+ OMP_CLAUSE_NOTEMPORAL,
+ OMP_CLAUSE_NUM_TASKS,
+ OMP_CLAUSE_PRIORITY,
+ OMP_CLAUSE_SIMD,
+ OMP_CLAUSE_THREADS,
+ OMP_CLAUSE_USE_DEVICE_PTR,
+ OMP_CLAUSE_USE_DEVICE_ADDR, /* OpenMP 5.0. */
+ OMP_CLAUSE_DEVICE_TYPE, /* OpenMP 5.0. */
+ OMP_CLAUSE_ATOMIC, /* OpenMP 5.0. */
+ OMP_CLAUSE_CAPTURE, /* OpenMP 5.0. */
+ OMP_CLAUSE_MEMORDER, /* OpenMP 5.0. */
+ OMP_CLAUSE_DETACH, /* OpenMP 5.0. */
+ OMP_CLAUSE_AFFINITY, /* OpenMP 5.0. */
+ OMP_CLAUSE_ALLOCATE, /* OpenMP 5.0. */
+ OMP_CLAUSE_BIND, /* OpenMP 5.0. */
+ OMP_CLAUSE_FILTER, /* OpenMP 5.1. */
+ OMP_CLAUSE_AT, /* OpenMP 5.1. */
+ OMP_CLAUSE_MESSAGE, /* OpenMP 5.1. */
+ OMP_CLAUSE_SEVERITY, /* OpenMP 5.1. */
+ OMP_CLAUSE_COMPARE, /* OpenMP 5.1. */
+ OMP_CLAUSE_FAIL, /* OpenMP 5.1. */
+ OMP_CLAUSE_WEAK, /* OpenMP 5.1. */
+ OMP_CLAUSE_NOWAIT,
+ /* This must come last. */
+ OMP_MASK1_LAST
+};
+
+/* OpenACC 2.0+ specific clauses. */
+enum omp_mask2
+{
+ OMP_CLAUSE_ASYNC,
+ OMP_CLAUSE_NUM_GANGS,
+ OMP_CLAUSE_NUM_WORKERS,
+ OMP_CLAUSE_VECTOR_LENGTH,
+ OMP_CLAUSE_COPY,
+ OMP_CLAUSE_COPYOUT,
+ OMP_CLAUSE_CREATE,
+ OMP_CLAUSE_NO_CREATE,
+ OMP_CLAUSE_PRESENT,
+ OMP_CLAUSE_DEVICEPTR,
+ OMP_CLAUSE_GANG,
+ OMP_CLAUSE_WORKER,
+ OMP_CLAUSE_VECTOR,
+ OMP_CLAUSE_SEQ,
+ OMP_CLAUSE_INDEPENDENT,
+ OMP_CLAUSE_USE_DEVICE,
+ OMP_CLAUSE_DEVICE_RESIDENT,
+ OMP_CLAUSE_HOST_SELF,
+ OMP_CLAUSE_WAIT,
+ OMP_CLAUSE_DELETE,
+ OMP_CLAUSE_AUTO,
+ OMP_CLAUSE_TILE,
+ OMP_CLAUSE_IF_PRESENT,
+ OMP_CLAUSE_FINALIZE,
+ OMP_CLAUSE_ATTACH,
+ OMP_CLAUSE_NOHOST,
+ /* This must come last. */
+ OMP_MASK2_LAST
+};
+
+struct omp_inv_mask;
+
+/* Customized bitset for up to 128-bits.
+ The two enums above provide bit numbers to use, and which of the
+ two enums it is determines which of the two mask fields is used.
+ Supported operations are defining a mask, like:
+ #define XXX_CLAUSES \
+ (omp_mask (OMP_CLAUSE_XXX) | OMP_CLAUSE_YYY | OMP_CLAUSE_ZZZ)
+ oring such bitsets together or removing selected bits:
+ (XXX_CLAUSES | YYY_CLAUSES) & ~(omp_mask (OMP_CLAUSE_VVV))
+ and testing individual bits:
+ if (mask & OMP_CLAUSE_UUU) */
+
+struct omp_mask {
+ const uint64_t mask1;
+ const uint64_t mask2;
+ inline omp_mask ();
+ inline omp_mask (omp_mask1);
+ inline omp_mask (omp_mask2);
+ inline omp_mask (uint64_t, uint64_t);
+ inline omp_mask operator| (omp_mask1) const;
+ inline omp_mask operator| (omp_mask2) const;
+ inline omp_mask operator| (omp_mask) const;
+ inline omp_mask operator& (const omp_inv_mask &) const;
+ inline bool operator& (omp_mask1) const;
+ inline bool operator& (omp_mask2) const;
+ inline omp_inv_mask operator~ () const;
+};
+
+struct omp_inv_mask : public omp_mask {
+ inline omp_inv_mask (const omp_mask &);
+};
+
+omp_mask::omp_mask () : mask1 (0), mask2 (0)
+{
+}
+
+omp_mask::omp_mask (omp_mask1 m) : mask1 (((uint64_t) 1) << m), mask2 (0)
+{
+}
+
+omp_mask::omp_mask (omp_mask2 m) : mask1 (0), mask2 (((uint64_t) 1) << m)
+{
+}
+
+omp_mask::omp_mask (uint64_t m1, uint64_t m2) : mask1 (m1), mask2 (m2)
+{
+}
+
+omp_mask
+omp_mask::operator| (omp_mask1 m) const
+{
+ return omp_mask (mask1 | (((uint64_t) 1) << m), mask2);
+}
+
+omp_mask
+omp_mask::operator| (omp_mask2 m) const
+{
+ return omp_mask (mask1, mask2 | (((uint64_t) 1) << m));
+}
+
+omp_mask
+omp_mask::operator| (omp_mask m) const
+{
+ return omp_mask (mask1 | m.mask1, mask2 | m.mask2);
+}
+
+omp_mask
+omp_mask::operator& (const omp_inv_mask &m) const
+{
+ return omp_mask (mask1 & ~m.mask1, mask2 & ~m.mask2);
+}
+
+bool
+omp_mask::operator& (omp_mask1 m) const
+{
+ return (mask1 & (((uint64_t) 1) << m)) != 0;
+}
+
+bool
+omp_mask::operator& (omp_mask2 m) const
+{
+ return (mask2 & (((uint64_t) 1) << m)) != 0;
+}
+
+omp_inv_mask
+omp_mask::operator~ () const
+{
+ return omp_inv_mask (*this);
+}
+
+omp_inv_mask::omp_inv_mask (const omp_mask &m) : omp_mask (m)
+{
+}
+
+/* Helper function for OpenACC and OpenMP clauses involving memory
+ mapping. */
+
+static bool
+gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op,
+ bool allow_common, bool allow_derived)
+{
+ gfc_omp_namelist **head = NULL;
+ if (gfc_match_omp_variable_list ("", list, allow_common, NULL, &head, true,
+ allow_derived)
+ == MATCH_YES)
+ {
+ gfc_omp_namelist *n;
+ for (n = *head; n; n = n->next)
+ n->u.map_op = map_op;
+ return true;
+ }
+
+ return false;
+}
+
+static match
+gfc_match_iterator (gfc_namespace **ns, bool permit_var)
+{
+ locus old_loc = gfc_current_locus;
+
+ if (gfc_match ("iterator ( ") != MATCH_YES)
+ return MATCH_NO;
+
+ gfc_typespec ts;
+ gfc_symbol *last = NULL;
+ gfc_expr *begin, *end, *step;
+ *ns = gfc_build_block_ns (gfc_current_ns);
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ while (true)
+ {
+ locus prev_loc = gfc_current_locus;
+ if (gfc_match_type_spec (&ts) == MATCH_YES
+ && gfc_match (" :: ") == MATCH_YES)
+ {
+ if (ts.type != BT_INTEGER)
+ {
+ gfc_error ("Expected INTEGER type at %L", &prev_loc);
+ return MATCH_ERROR;
+ }
+ permit_var = false;
+ }
+ else
+ {
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_default_integer_kind;
+ gfc_current_locus = prev_loc;
+ }
+ prev_loc = gfc_current_locus;
+ if (gfc_match_name (name) != MATCH_YES)
+ {
+ gfc_error ("Expected identifier at %C");
+ goto failed;
+ }
+ if (gfc_find_symtree ((*ns)->sym_root, name))
+ {
+ gfc_error ("Same identifier %qs specified again at %C", name);
+ goto failed;
+ }
+
+ gfc_symbol *sym = gfc_new_symbol (name, *ns);
+ if (last)
+ last->tlink = sym;
+ else
+ (*ns)->proc_name = sym;
+ last = sym;
+ sym->declared_at = prev_loc;
+ sym->ts = ts;
+ sym->attr.flavor = FL_VARIABLE;
+ sym->attr.artificial = 1;
+ sym->attr.referenced = 1;
+ sym->refs++;
+ gfc_symtree *st = gfc_new_symtree (&(*ns)->sym_root, name);
+ st->n.sym = sym;
+
+ prev_loc = gfc_current_locus;
+ if (gfc_match (" = ") != MATCH_YES)
+ goto failed;
+ permit_var = false;
+ begin = end = step = NULL;
+ if (gfc_match ("%e : ", &begin) != MATCH_YES
+ || gfc_match ("%e ", &end) != MATCH_YES)
+ {
+ gfc_error ("Expected range-specification at %C");
+ gfc_free_expr (begin);
+ gfc_free_expr (end);
+ return MATCH_ERROR;
+ }
+ if (':' == gfc_peek_ascii_char ())
+ {
+ step = gfc_get_expr ();
+ if (gfc_match (": %e ", &step) != MATCH_YES)
+ {
+ gfc_free_expr (begin);
+ gfc_free_expr (end);
+ gfc_free_expr (step);
+ goto failed;
+ }
+ }
+
+ gfc_expr *e = gfc_get_expr ();
+ e->where = prev_loc;
+ e->expr_type = EXPR_ARRAY;
+ e->ts = ts;
+ e->rank = 1;
+ e->shape = gfc_get_shape (1);
+ mpz_init_set_ui (e->shape[0], step ? 3 : 2);
+ gfc_constructor_append_expr (&e->value.constructor, begin, &begin->where);
+ gfc_constructor_append_expr (&e->value.constructor, end, &end->where);
+ if (step)
+ gfc_constructor_append_expr (&e->value.constructor, step, &step->where);
+ sym->value = e;
+
+ if (gfc_match (") ") == MATCH_YES)
+ break;
+ if (gfc_match (", ") != MATCH_YES)
+ goto failed;
+ }
+ return MATCH_YES;
+
+failed:
+ gfc_namespace *prev_ns = NULL;
+ for (gfc_namespace *it = gfc_current_ns->contained; it; it = it->sibling)
+ {
+ if (it == *ns)
+ {
+ if (prev_ns)
+ prev_ns->sibling = it->sibling;
+ else
+ gfc_current_ns->contained = it->sibling;
+ gfc_free_namespace (it);
+ break;
+ }
+ prev_ns = it;
+ }
+ *ns = NULL;
+ if (!permit_var)
+ return MATCH_ERROR;
+ gfc_current_locus = old_loc;
+ return MATCH_NO;
+}
+
+/* reduction ( reduction-modifier, reduction-operator : variable-list )
+ in_reduction ( reduction-operator : variable-list )
+ task_reduction ( reduction-operator : variable-list ) */
+
+static match
+gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
+ bool allow_derived, bool openmp_target = false)
+{
+ if (pc == 'r' && gfc_match ("reduction ( ") != MATCH_YES)
+ return MATCH_NO;
+ else if (pc == 'i' && gfc_match ("in_reduction ( ") != MATCH_YES)
+ return MATCH_NO;
+ else if (pc == 't' && gfc_match ("task_reduction ( ") != MATCH_YES)
+ return MATCH_NO;
+
+ locus old_loc = gfc_current_locus;
+ int list_idx = 0;
+
+ if (pc == 'r' && !openacc)
+ {
+ if (gfc_match ("inscan") == MATCH_YES)
+ list_idx = OMP_LIST_REDUCTION_INSCAN;
+ else if (gfc_match ("task") == MATCH_YES)
+ list_idx = OMP_LIST_REDUCTION_TASK;
+ else if (gfc_match ("default") == MATCH_YES)
+ list_idx = OMP_LIST_REDUCTION;
+ if (list_idx != 0 && gfc_match (", ") != MATCH_YES)
+ {
+ gfc_error ("Comma expected at %C");
+ gfc_current_locus = old_loc;
+ return MATCH_NO;
+ }
+ if (list_idx == 0)
+ list_idx = OMP_LIST_REDUCTION;
+ }
+ else if (pc == 'i')
+ list_idx = OMP_LIST_IN_REDUCTION;
+ else if (pc == 't')
+ list_idx = OMP_LIST_TASK_REDUCTION;
+ else
+ list_idx = OMP_LIST_REDUCTION;
+
+ gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
+ char buffer[GFC_MAX_SYMBOL_LEN + 3];
+ if (gfc_match_char ('+') == MATCH_YES)
+ rop = OMP_REDUCTION_PLUS;
+ else if (gfc_match_char ('*') == MATCH_YES)
+ rop = OMP_REDUCTION_TIMES;
+ else if (gfc_match_char ('-') == MATCH_YES)
+ rop = OMP_REDUCTION_MINUS;
+ else if (gfc_match (".and.") == MATCH_YES)
+ rop = OMP_REDUCTION_AND;
+ else if (gfc_match (".or.") == MATCH_YES)
+ rop = OMP_REDUCTION_OR;
+ else if (gfc_match (".eqv.") == MATCH_YES)
+ rop = OMP_REDUCTION_EQV;
+ else if (gfc_match (".neqv.") == MATCH_YES)
+ rop = OMP_REDUCTION_NEQV;
+ if (rop != OMP_REDUCTION_NONE)
+ snprintf (buffer, sizeof buffer, "operator %s",
+ gfc_op2string ((gfc_intrinsic_op) rop));
+ else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES)
+ {
+ buffer[0] = '.';
+ strcat (buffer, ".");
+ }
+ else if (gfc_match_name (buffer) == MATCH_YES)
+ {
+ gfc_symbol *sym;
+ const char *n = buffer;
+
+ gfc_find_symbol (buffer, NULL, 1, &sym);
+ if (sym != NULL)
+ {
+ if (sym->attr.intrinsic)
+ n = sym->name;
+ else if ((sym->attr.flavor != FL_UNKNOWN
+ && sym->attr.flavor != FL_PROCEDURE)
+ || sym->attr.external
+ || sym->attr.generic
+ || sym->attr.entry
+ || sym->attr.result
+ || sym->attr.dummy
+ || sym->attr.subroutine
+ || sym->attr.pointer
+ || sym->attr.target
+ || sym->attr.cray_pointer
+ || sym->attr.cray_pointee
+ || (sym->attr.proc != PROC_UNKNOWN
+ && sym->attr.proc != PROC_INTRINSIC)
+ || sym->attr.if_source != IFSRC_UNKNOWN
+ || sym == sym->ns->proc_name)
+ {
+ sym = NULL;
+ n = NULL;
+ }
+ else
+ n = sym->name;
+ }
+ if (n == NULL)
+ rop = OMP_REDUCTION_NONE;
+ else if (strcmp (n, "max") == 0)
+ rop = OMP_REDUCTION_MAX;
+ else if (strcmp (n, "min") == 0)
+ rop = OMP_REDUCTION_MIN;
+ else if (strcmp (n, "iand") == 0)
+ rop = OMP_REDUCTION_IAND;
+ else if (strcmp (n, "ior") == 0)
+ rop = OMP_REDUCTION_IOR;
+ else if (strcmp (n, "ieor") == 0)
+ rop = OMP_REDUCTION_IEOR;
+ if (rop != OMP_REDUCTION_NONE
+ && sym != NULL
+ && ! sym->attr.intrinsic
+ && ! sym->attr.use_assoc
+ && ((sym->attr.flavor == FL_UNKNOWN
+ && !gfc_add_flavor (&sym->attr, FL_PROCEDURE,
+ sym->name, NULL))
+ || !gfc_add_intrinsic (&sym->attr, NULL)))
+ rop = OMP_REDUCTION_NONE;
+ }
+ else
+ buffer[0] = '\0';
+ gfc_omp_udr *udr = (buffer[0] ? gfc_find_omp_udr (gfc_current_ns, buffer, NULL)
+ : NULL);
+ gfc_omp_namelist **head = NULL;
+ if (rop == OMP_REDUCTION_NONE && udr)
+ rop = OMP_REDUCTION_USER;
+
+ if (gfc_match_omp_variable_list (" :", &c->lists[list_idx], false, NULL,
+ &head, openacc, allow_derived) != MATCH_YES)
+ {
+ gfc_current_locus = old_loc;
+ return MATCH_NO;
+ }
+ gfc_omp_namelist *n;
+ if (rop == OMP_REDUCTION_NONE)
+ {
+ n = *head;
+ *head = NULL;
+ gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L",
+ buffer, &old_loc);
+ gfc_free_omp_namelist (n, false);
+ }
+ else
+ for (n = *head; n; n = n->next)
+ {
+ n->u.reduction_op = rop;
+ if (udr)
+ {
+ n->u2.udr = gfc_get_omp_namelist_udr ();
+ n->u2.udr->udr = udr;
+ }
+ if (openmp_target && list_idx == OMP_LIST_IN_REDUCTION)
+ {
+ gfc_omp_namelist *p = gfc_get_omp_namelist (), **tl;
+ p->sym = n->sym;
+ p->where = p->where;
+ p->u.map_op = OMP_MAP_ALWAYS_TOFROM;
+
+ tl = &c->lists[OMP_LIST_MAP];
+ while (*tl)
+ tl = &((*tl)->next);
+ *tl = p;
+ p->next = NULL;
+ }
+ }
+ return MATCH_YES;
+}
+
+
+/* Match with duplicate check. Matches 'name'. If expr != NULL, it
+ then matches '(expr)', otherwise, if open_parens is true,
+ it matches a ' ( ' after 'name'.
+ dupl_message requires '%qs %L' - and is used by
+ gfc_match_dupl_memorder and gfc_match_dupl_atomic. */
+
+static match
+gfc_match_dupl_check (bool not_dupl, const char *name, bool open_parens = false,
+ gfc_expr **expr = NULL, const char *dupl_msg = NULL)
+{
+ match m;
+ locus old_loc = gfc_current_locus;
+ if ((m = gfc_match (name)) != MATCH_YES)
+ return m;
+ if (!not_dupl)
+ {
+ if (dupl_msg)
+ gfc_error (dupl_msg, name, &old_loc);
+ else
+ gfc_error ("Duplicated %qs clause at %L", name, &old_loc);
+ return MATCH_ERROR;
+ }
+ if (open_parens || expr)
+ {
+ if (gfc_match (" ( ") != MATCH_YES)
+ {
+ gfc_error ("Expected %<(%> after %qs at %C", name);
+ return MATCH_ERROR;
+ }
+ if (expr)
+ {
+ if (gfc_match ("%e )", expr) != MATCH_YES)
+ {
+ gfc_error ("Invalid expression after %<%s(%> at %C", name);
+ return MATCH_ERROR;
+ }
+ }
+ }
+ return MATCH_YES;
+}
+
+static match
+gfc_match_dupl_memorder (bool not_dupl, const char *name)
+{
+ return gfc_match_dupl_check (not_dupl, name, false, NULL,
+ "Duplicated memory-order clause: unexpected %s "
+ "clause at %L");
+}
+
+static match
+gfc_match_dupl_atomic (bool not_dupl, const char *name)
+{
+ return gfc_match_dupl_check (not_dupl, name, false, NULL,
+ "Duplicated atomic clause: unexpected %s "
+ "clause at %L");
+}
+
+/* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of
+ clauses that are allowed for a particular directive. */
+
+static match
+gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
+ bool first = true, bool needs_space = true,
+ bool openacc = false, bool context_selector = false,
+ bool openmp_target = false)
+{
+ bool error = false;
+ gfc_omp_clauses *c = gfc_get_omp_clauses ();
+ locus old_loc;
+ /* Determine whether we're dealing with an OpenACC directive that permits
+ derived type member accesses. This in particular disallows
+ "!$acc declare" from using such accesses, because it's not clear if/how
+ that should work. */
+ bool allow_derived = (openacc
+ && ((mask & OMP_CLAUSE_ATTACH)
+ || (mask & OMP_CLAUSE_DETACH)
+ || (mask & OMP_CLAUSE_HOST_SELF)));
+
+ gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
+ *cp = NULL;
+ while (1)
+ {
+ match m = MATCH_NO;
+ if ((first || (m = gfc_match_char (',')) != MATCH_YES)
+ && (needs_space && gfc_match_space () != MATCH_YES))
+ break;
+ needs_space = false;
+ first = false;
+ gfc_gobble_whitespace ();
+ bool end_colon;
+ gfc_omp_namelist **head;
+ old_loc = gfc_current_locus;
+ char pc = gfc_peek_ascii_char ();
+ if (pc == '\n' && m == MATCH_YES)
+ {
+ gfc_error ("Clause expected at %C after trailing comma");
+ goto error;
+ }
+ switch (pc)
+ {
+ case 'a':
+ end_colon = false;
+ head = NULL;
+ if ((mask & OMP_CLAUSE_ALIGNED)
+ && gfc_match_omp_variable_list ("aligned (",
+ &c->lists[OMP_LIST_ALIGNED],
+ false, &end_colon,
+ &head) == MATCH_YES)
+ {
+ gfc_expr *alignment = NULL;
+ gfc_omp_namelist *n;
+
+ if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES)
+ {
+ gfc_free_omp_namelist (*head, false);
+ gfc_current_locus = old_loc;
+ *head = NULL;
+ break;
+ }
+ for (n = *head; n; n = n->next)
+ if (n->next && alignment)
+ n->expr = gfc_copy_expr (alignment);
+ else
+ n->expr = alignment;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_MEMORDER)
+ && (m = gfc_match_dupl_memorder ((c->memorder
+ == OMP_MEMORDER_UNSET),
+ "acq_rel")) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->memorder = OMP_MEMORDER_ACQ_REL;
+ needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_MEMORDER)
+ && (m = gfc_match_dupl_memorder ((c->memorder
+ == OMP_MEMORDER_UNSET),
+ "acquire")) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->memorder = OMP_MEMORDER_ACQUIRE;
+ needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_AFFINITY)
+ && gfc_match ("affinity ( ") == MATCH_YES)
+ {
+ gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
+ m = gfc_match_iterator (&ns_iter, true);
+ if (m == MATCH_ERROR)
+ break;
+ if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
+ {
+ gfc_error ("Expected %<:%> at %C");
+ break;
+ }
+ if (ns_iter)
+ gfc_current_ns = ns_iter;
+ head = NULL;
+ m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_AFFINITY],
+ false, NULL, &head, true);
+ gfc_current_ns = ns_curr;
+ if (m == MATCH_ERROR)
+ break;
+ if (ns_iter)
+ {
+ for (gfc_omp_namelist *n = *head; n; n = n->next)
+ {
+ n->u2.ns = ns_iter;
+ ns_iter->refs++;
+ }
+ }
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_ALLOCATE)
+ && gfc_match ("allocate ( ") == MATCH_YES)
+ {
+ gfc_expr *allocator = NULL;
+ old_loc = gfc_current_locus;
+ m = gfc_match_expr (&allocator);
+ if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
+ {
+ /* If no ":" then there is no allocator, we backtrack
+ and read the variable list. */
+ gfc_free_expr (allocator);
+ allocator = NULL;
+ gfc_current_locus = old_loc;
+ }
+
+ gfc_omp_namelist **head = NULL;
+ m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_ALLOCATE],
+ true, NULL, &head);
+
+ if (m != MATCH_YES)
+ {
+ gfc_free_expr (allocator);
+ gfc_error ("Expected variable list at %C");
+ goto error;
+ }
+
+ for (gfc_omp_namelist *n = *head; n; n = n->next)
+ if (allocator)
+ n->expr = gfc_copy_expr (allocator);
+ else
+ n->expr = NULL;
+ gfc_free_expr (allocator);
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_AT)
+ && (m = gfc_match_dupl_check (c->at == OMP_AT_UNSET, "at", true))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ if (gfc_match ("compilation )") == MATCH_YES)
+ c->at = OMP_AT_COMPILATION;
+ else if (gfc_match ("execution )") == MATCH_YES)
+ c->at = OMP_AT_EXECUTION;
+ else
+ {
+ gfc_error ("Expected COMPILATION or EXECUTION in AT clause "
+ "at %C");
+ goto error;
+ }
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_ASYNC)
+ && (m = gfc_match_dupl_check (!c->async, "async")) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->async = true;
+ m = gfc_match (" ( %e )", &c->async_expr);
+ if (m == MATCH_ERROR)
+ {
+ gfc_current_locus = old_loc;
+ break;
+ }
+ else if (m == MATCH_NO)
+ {
+ c->async_expr
+ = gfc_get_constant_expr (BT_INTEGER,
+ gfc_default_integer_kind,
+ &gfc_current_locus);
+ mpz_set_si (c->async_expr->value.integer, GOMP_ASYNC_NOVAL);
+ needs_space = true;
+ }
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_AUTO)
+ && (m = gfc_match_dupl_check (!c->par_auto, "auto"))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->par_auto = true;
+ needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_ATTACH)
+ && gfc_match ("attach ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_ATTACH, false,
+ allow_derived))
+ continue;
+ break;
+ case 'b':
+ if ((mask & OMP_CLAUSE_BIND)
+ && (m = gfc_match_dupl_check (c->bind == OMP_BIND_UNSET, "bind",
+ true)) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ if (gfc_match ("teams )") == MATCH_YES)
+ c->bind = OMP_BIND_TEAMS;
+ else if (gfc_match ("parallel )") == MATCH_YES)
+ c->bind = OMP_BIND_PARALLEL;
+ else if (gfc_match ("thread )") == MATCH_YES)
+ c->bind = OMP_BIND_THREAD;
+ else
+ {
+ gfc_error ("Expected TEAMS, PARALLEL or THREAD as binding in "
+ "BIND at %C");
+ break;
+ }
+ continue;
+ }
+ break;
+ case 'c':
+ if ((mask & OMP_CLAUSE_CAPTURE)
+ && (m = gfc_match_dupl_check (!c->capture, "capture"))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->capture = true;
+ needs_space = true;
+ continue;
+ }
+ if (mask & OMP_CLAUSE_COLLAPSE)
+ {
+ gfc_expr *cexpr = NULL;
+ if ((m = gfc_match_dupl_check (!c->collapse, "collapse", true,
+ &cexpr)) != MATCH_NO)
+ {
+ int collapse;
+ if (m == MATCH_ERROR)
+ goto error;
+ if (gfc_extract_int (cexpr, &collapse, -1))
+ collapse = 1;
+ else if (collapse <= 0)
+ {
+ gfc_error_now ("COLLAPSE clause argument not constant "
+ "positive integer at %C");
+ collapse = 1;
+ }
+ gfc_free_expr (cexpr);
+ c->collapse = collapse;
+ continue;
+ }
+ }
+ if ((mask & OMP_CLAUSE_COMPARE)
+ && (m = gfc_match_dupl_check (!c->compare, "compare"))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->compare = true;
+ needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_COPY)
+ && gfc_match ("copy ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_TOFROM, true,
+ allow_derived))
+ continue;
+ if (mask & OMP_CLAUSE_COPYIN)
+ {
+ if (openacc)
+ {
+ if (gfc_match ("copyin ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_TO, true,
+ allow_derived))
+ continue;
+ }
+ else if (gfc_match_omp_variable_list ("copyin (",
+ &c->lists[OMP_LIST_COPYIN],
+ true) == MATCH_YES)
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_COPYOUT)
+ && gfc_match ("copyout ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_FROM, true, allow_derived))
+ continue;
+ if ((mask & OMP_CLAUSE_COPYPRIVATE)
+ && gfc_match_omp_variable_list ("copyprivate (",
+ &c->lists[OMP_LIST_COPYPRIVATE],
+ true) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_CREATE)
+ && gfc_match ("create ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_ALLOC, true, allow_derived))
+ continue;
+ break;
+ case 'd':
+ if ((mask & OMP_CLAUSE_DEFAULTMAP)
+ && gfc_match ("defaultmap ( ") == MATCH_YES)
+ {
+ enum gfc_omp_defaultmap behavior;
+ gfc_omp_defaultmap_category category
+ = OMP_DEFAULTMAP_CAT_UNCATEGORIZED;
+ if (gfc_match ("alloc ") == MATCH_YES)
+ behavior = OMP_DEFAULTMAP_ALLOC;
+ else if (gfc_match ("tofrom ") == MATCH_YES)
+ behavior = OMP_DEFAULTMAP_TOFROM;
+ else if (gfc_match ("to ") == MATCH_YES)
+ behavior = OMP_DEFAULTMAP_TO;
+ else if (gfc_match ("from ") == MATCH_YES)
+ behavior = OMP_DEFAULTMAP_FROM;
+ else if (gfc_match ("firstprivate ") == MATCH_YES)
+ behavior = OMP_DEFAULTMAP_FIRSTPRIVATE;
+ else if (gfc_match ("none ") == MATCH_YES)
+ behavior = OMP_DEFAULTMAP_NONE;
+ else if (gfc_match ("default ") == MATCH_YES)
+ behavior = OMP_DEFAULTMAP_DEFAULT;
+ else
+ {
+ gfc_error ("Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, "
+ "NONE or DEFAULT at %C");
+ break;
+ }
+ if (')' == gfc_peek_ascii_char ())
+ ;
+ else if (gfc_match (": ") != MATCH_YES)
+ break;
+ else
+ {
+ if (gfc_match ("scalar ") == MATCH_YES)
+ category = OMP_DEFAULTMAP_CAT_SCALAR;
+ else if (gfc_match ("aggregate ") == MATCH_YES)
+ category = OMP_DEFAULTMAP_CAT_AGGREGATE;
+ else if (gfc_match ("allocatable ") == MATCH_YES)
+ category = OMP_DEFAULTMAP_CAT_ALLOCATABLE;
+ else if (gfc_match ("pointer ") == MATCH_YES)
+ category = OMP_DEFAULTMAP_CAT_POINTER;
+ else
+ {
+ gfc_error ("Expected SCALAR, AGGREGATE, ALLOCATABLE or "
+ "POINTER at %C");
+ break;
+ }
+ }
+ for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; ++i)
+ {
+ if (i != category
+ && category != OMP_DEFAULTMAP_CAT_UNCATEGORIZED)
+ continue;
+ if (c->defaultmap[i] != OMP_DEFAULTMAP_UNSET)
+ {
+ const char *pcategory = NULL;
+ switch (i)
+ {
+ case OMP_DEFAULTMAP_CAT_UNCATEGORIZED: break;
+ case OMP_DEFAULTMAP_CAT_SCALAR: pcategory = "SCALAR"; break;
+ case OMP_DEFAULTMAP_CAT_AGGREGATE:
+ pcategory = "AGGREGATE";
+ break;
+ case OMP_DEFAULTMAP_CAT_ALLOCATABLE:
+ pcategory = "ALLOCATABLE";
+ break;
+ case OMP_DEFAULTMAP_CAT_POINTER:
+ pcategory = "POINTER";
+ break;
+ default: gcc_unreachable ();
+ }
+ if (i == OMP_DEFAULTMAP_CAT_UNCATEGORIZED)
+ gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP with "
+ "unspecified category");
+ else
+ gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP for "
+ "category %s", pcategory);
+ goto error;
+ }
+ }
+ c->defaultmap[category] = behavior;
+ if (gfc_match (")") != MATCH_YES)
+ break;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_DEFAULT)
+ && (m = gfc_match_dupl_check (c->default_sharing
+ == OMP_DEFAULT_UNKNOWN, "default",
+ true)) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ if (gfc_match ("none") == MATCH_YES)
+ c->default_sharing = OMP_DEFAULT_NONE;
+ else if (openacc)
+ {
+ if (gfc_match ("present") == MATCH_YES)
+ c->default_sharing = OMP_DEFAULT_PRESENT;
+ }
+ else
+ {
+ if (gfc_match ("firstprivate") == MATCH_YES)
+ c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
+ else if (gfc_match ("private") == MATCH_YES)
+ c->default_sharing = OMP_DEFAULT_PRIVATE;
+ else if (gfc_match ("shared") == MATCH_YES)
+ c->default_sharing = OMP_DEFAULT_SHARED;
+ }
+ if (c->default_sharing == OMP_DEFAULT_UNKNOWN)
+ {
+ if (openacc)
+ gfc_error ("Expected NONE or PRESENT in DEFAULT clause "
+ "at %C");
+ else
+ gfc_error ("Expected NONE, FIRSTPRIVATE, PRIVATE or SHARED "
+ "in DEFAULT clause at %C");
+ goto error;
+ }
+ if (gfc_match (" )") != MATCH_YES)
+ goto error;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_DELETE)
+ && gfc_match ("delete ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_RELEASE, true,
+ allow_derived))
+ continue;
+ if ((mask & OMP_CLAUSE_DEPEND)
+ && gfc_match ("depend ( ") == MATCH_YES)
+ {
+ gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
+ match m_it = gfc_match_iterator (&ns_iter, false);
+ if (m_it == MATCH_ERROR)
+ break;
+ if (m_it == MATCH_YES && gfc_match (" , ") != MATCH_YES)
+ break;
+ m = MATCH_YES;
+ gfc_omp_depend_op depend_op = OMP_DEPEND_OUT;
+ if (gfc_match ("inout") == MATCH_YES)
+ depend_op = OMP_DEPEND_INOUT;
+ else if (gfc_match ("in") == MATCH_YES)
+ depend_op = OMP_DEPEND_IN;
+ else if (gfc_match ("out") == MATCH_YES)
+ depend_op = OMP_DEPEND_OUT;
+ else if (gfc_match ("mutexinoutset") == MATCH_YES)
+ depend_op = OMP_DEPEND_MUTEXINOUTSET;
+ else if (gfc_match ("depobj") == MATCH_YES)
+ depend_op = OMP_DEPEND_DEPOBJ;
+ else if (!c->depend_source
+ && gfc_match ("source )") == MATCH_YES)
+ {
+ if (m_it == MATCH_YES)
+ {
+ gfc_error ("ITERATOR may not be combined with SOURCE "
+ "at %C");
+ gfc_free_omp_clauses (c);
+ return MATCH_ERROR;
+ }
+ c->depend_source = true;
+ continue;
+ }
+ else if (gfc_match ("sink : ") == MATCH_YES)
+ {
+ if (m_it == MATCH_YES)
+ {
+ gfc_error ("ITERATOR may not be combined with SINK "
+ "at %C");
+ break;
+ }
+ if (gfc_match_omp_depend_sink (&c->lists[OMP_LIST_DEPEND])
+ == MATCH_YES)
+ continue;
+ m = MATCH_NO;
+ }
+ else
+ m = MATCH_NO;
+ head = NULL;
+ if (ns_iter)
+ gfc_current_ns = ns_iter;
+ if (m == MATCH_YES)
+ m = gfc_match_omp_variable_list (" : ",
+ &c->lists[OMP_LIST_DEPEND],
+ false, NULL, &head, true);
+ gfc_current_ns = ns_curr;
+ if (m == MATCH_YES)
+ {
+ gfc_omp_namelist *n;
+ for (n = *head; n; n = n->next)
+ {
+ n->u.depend_op = depend_op;
+ n->u2.ns = ns_iter;
+ if (ns_iter)
+ ns_iter->refs++;
+ }
+ continue;
+ }
+ break;
+ }
+ if ((mask & OMP_CLAUSE_DETACH)
+ && !openacc
+ && !c->detach
+ && gfc_match_omp_detach (&c->detach) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_DETACH)
+ && openacc
+ && gfc_match ("detach ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_DETACH, false,
+ allow_derived))
+ continue;
+ if ((mask & OMP_CLAUSE_DEVICE)
+ && !openacc
+ && ((m = gfc_match_dupl_check (!c->device, "device", true))
+ != MATCH_NO))
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->ancestor = false;
+ if (gfc_match ("device_num : ") == MATCH_YES)
+ {
+ if (gfc_match ("%e )", &c->device) != MATCH_YES)
+ {
+ gfc_error ("Expected integer expression at %C");
+ break;
+ }
+ }
+ else if (gfc_match ("ancestor : ") == MATCH_YES)
+ {
+ c->ancestor = true;
+ if (!(gfc_current_ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD))
+ {
+ gfc_error ("%<ancestor%> device modifier not "
+ "preceded by %<requires%> directive "
+ "with %<reverse_offload%> clause at %C");
+ break;
+ }
+ locus old_loc2 = gfc_current_locus;
+ if (gfc_match ("%e )", &c->device) == MATCH_YES)
+ {
+ int device = 0;
+ if (!gfc_extract_int (c->device, &device) && device != 1)
+ {
+ gfc_current_locus = old_loc2;
+ gfc_error ("the %<device%> clause expression must "
+ "evaluate to %<1%> at %C");
+ break;
+ }
+ }
+ else
+ {
+ gfc_error ("Expected integer expression at %C");
+ break;
+ }
+ }
+ else if (gfc_match ("%e )", &c->device) != MATCH_YES)
+ {
+ gfc_error ("Expected integer expression or a single device-"
+ "modifier %<device_num%> or %<ancestor%> at %C");
+ break;
+ }
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_DEVICE)
+ && openacc
+ && gfc_match ("device ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_FORCE_TO, true,
+ allow_derived))
+ continue;
+ if ((mask & OMP_CLAUSE_DEVICEPTR)
+ && gfc_match ("deviceptr ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_FORCE_DEVICEPTR, false,
+ allow_derived))
+ continue;
+ if ((mask & OMP_CLAUSE_DEVICE_TYPE)
+ && gfc_match ("device_type ( ") == MATCH_YES)
+ {
+ if (gfc_match ("host") == MATCH_YES)
+ c->device_type = OMP_DEVICE_TYPE_HOST;
+ else if (gfc_match ("nohost") == MATCH_YES)
+ c->device_type = OMP_DEVICE_TYPE_NOHOST;
+ else if (gfc_match ("any") == MATCH_YES)
+ c->device_type = OMP_DEVICE_TYPE_ANY;
+ else
+ {
+ gfc_error ("Expected HOST, NOHOST or ANY at %C");
+ break;
+ }
+ if (gfc_match (" )") != MATCH_YES)
+ break;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
+ && gfc_match_omp_variable_list
+ ("device_resident (",
+ &c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_DIST_SCHEDULE)
+ && c->dist_sched_kind == OMP_SCHED_NONE
+ && gfc_match ("dist_schedule ( static") == MATCH_YES)
+ {
+ m = MATCH_NO;
+ c->dist_sched_kind = OMP_SCHED_STATIC;
+ m = gfc_match (" , %e )", &c->dist_chunk_size);
+ if (m != MATCH_YES)
+ m = gfc_match_char (')');
+ if (m != MATCH_YES)
+ {
+ c->dist_sched_kind = OMP_SCHED_NONE;
+ gfc_current_locus = old_loc;
+ }
+ else
+ continue;
+ }
+ break;
+ case 'f':
+ if ((mask & OMP_CLAUSE_FAIL)
+ && (m = gfc_match_dupl_check (c->fail == OMP_MEMORDER_UNSET,
+ "fail", true)) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ if (gfc_match ("seq_cst") == MATCH_YES)
+ c->fail = OMP_MEMORDER_SEQ_CST;
+ else if (gfc_match ("acquire") == MATCH_YES)
+ c->fail = OMP_MEMORDER_ACQUIRE;
+ else if (gfc_match ("relaxed") == MATCH_YES)
+ c->fail = OMP_MEMORDER_RELAXED;
+ else
+ {
+ gfc_error ("Expected SEQ_CST, ACQUIRE or RELAXED at %C");
+ break;
+ }
+ if (gfc_match (" )") != MATCH_YES)
+ goto error;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_FILTER)
+ && (m = gfc_match_dupl_check (!c->filter, "filter", true,
+ &c->filter)) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_FINAL)
+ && (m = gfc_match_dupl_check (!c->final_expr, "final", true,
+ &c->final_expr)) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_FINALIZE)
+ && (m = gfc_match_dupl_check (!c->finalize, "finalize"))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->finalize = true;
+ needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
+ && gfc_match_omp_variable_list ("firstprivate (",
+ &c->lists[OMP_LIST_FIRSTPRIVATE],
+ true) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_FROM)
+ && gfc_match_omp_variable_list ("from (",
+ &c->lists[OMP_LIST_FROM], false,
+ NULL, &head, true) == MATCH_YES)
+ continue;
+ break;
+ case 'g':
+ if ((mask & OMP_CLAUSE_GANG)
+ && (m = gfc_match_dupl_check (!c->gang, "gang")) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->gang = true;
+ m = match_oacc_clause_gwv (c, GOMP_DIM_GANG);
+ if (m == MATCH_ERROR)
+ {
+ gfc_current_locus = old_loc;
+ break;
+ }
+ else if (m == MATCH_NO)
+ needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_GRAINSIZE)
+ && (m = gfc_match_dupl_check (!c->grainsize, "grainsize", true))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ if (gfc_match ("strict : ") == MATCH_YES)
+ c->grainsize_strict = true;
+ if (gfc_match (" %e )", &c->grainsize) != MATCH_YES)
+ goto error;
+ continue;
+ }
+ break;
+ case 'h':
+ if ((mask & OMP_CLAUSE_HINT)
+ && (m = gfc_match_dupl_check (!c->hint, "hint", true, &c->hint))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_HOST_SELF)
+ && gfc_match ("host ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_FORCE_FROM, true,
+ allow_derived))
+ continue;
+ break;
+ case 'i':
+ if ((mask & OMP_CLAUSE_IF_PRESENT)
+ && (m = gfc_match_dupl_check (!c->if_present, "if_present"))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->if_present = true;
+ needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_IF)
+ && (m = gfc_match_dupl_check (!c->if_expr, "if", true))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ if (!openacc)
+ {
+ /* This should match the enum gfc_omp_if_kind order. */
+ static const char *ifs[OMP_IF_LAST] = {
+ "cancel : %e )",
+ "parallel : %e )",
+ "simd : %e )",
+ "task : %e )",
+ "taskloop : %e )",
+ "target : %e )",
+ "target data : %e )",
+ "target update : %e )",
+ "target enter data : %e )",
+ "target exit data : %e )" };
+ int i;
+ for (i = 0; i < OMP_IF_LAST; i++)
+ if (c->if_exprs[i] == NULL
+ && gfc_match (ifs[i], &c->if_exprs[i]) == MATCH_YES)
+ break;
+ if (i < OMP_IF_LAST)
+ continue;
+ }
+ if (gfc_match (" %e )", &c->if_expr) == MATCH_YES)
+ continue;
+ goto error;
+ }
+ if ((mask & OMP_CLAUSE_IN_REDUCTION)
+ && gfc_match_omp_clause_reduction (pc, c, openacc, allow_derived,
+ openmp_target) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_INBRANCH)
+ && (m = gfc_match_dupl_check (!c->inbranch && !c->notinbranch,
+ "inbranch")) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->inbranch = needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_INDEPENDENT)
+ && (m = gfc_match_dupl_check (!c->independent, "independent"))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->independent = true;
+ needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_IS_DEVICE_PTR)
+ && gfc_match_omp_variable_list
+ ("is_device_ptr (",
+ &c->lists[OMP_LIST_IS_DEVICE_PTR], false) == MATCH_YES)
+ continue;
+ break;
+ case 'l':
+ if ((mask & OMP_CLAUSE_LASTPRIVATE)
+ && gfc_match ("lastprivate ( ") == MATCH_YES)
+ {
+ bool conditional = gfc_match ("conditional : ") == MATCH_YES;
+ head = NULL;
+ if (gfc_match_omp_variable_list ("",
+ &c->lists[OMP_LIST_LASTPRIVATE],
+ false, NULL, &head) == MATCH_YES)
+ {
+ gfc_omp_namelist *n;
+ for (n = *head; n; n = n->next)
+ n->u.lastprivate_conditional = conditional;
+ continue;
+ }
+ gfc_current_locus = old_loc;
+ break;
+ }
+ end_colon = false;
+ head = NULL;
+ if ((mask & OMP_CLAUSE_LINEAR)
+ && gfc_match ("linear (") == MATCH_YES)
+ {
+ gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
+ gfc_expr *step = NULL;
+
+ if (gfc_match_omp_variable_list (" ref (",
+ &c->lists[OMP_LIST_LINEAR],
+ false, NULL, &head)
+ == MATCH_YES)
+ linear_op = OMP_LINEAR_REF;
+ else if (gfc_match_omp_variable_list (" val (",
+ &c->lists[OMP_LIST_LINEAR],
+ false, NULL, &head)
+ == MATCH_YES)
+ linear_op = OMP_LINEAR_VAL;
+ else if (gfc_match_omp_variable_list (" uval (",
+ &c->lists[OMP_LIST_LINEAR],
+ false, NULL, &head)
+ == MATCH_YES)
+ linear_op = OMP_LINEAR_UVAL;
+ else if (gfc_match_omp_variable_list ("",
+ &c->lists[OMP_LIST_LINEAR],
+ false, &end_colon, &head)
+ == MATCH_YES)
+ linear_op = OMP_LINEAR_DEFAULT;
+ else
+ {
+ gfc_current_locus = old_loc;
+ break;
+ }
+ if (linear_op != OMP_LINEAR_DEFAULT)
+ {
+ if (gfc_match (" :") == MATCH_YES)
+ end_colon = true;
+ else if (gfc_match (" )") != MATCH_YES)
+ {
+ gfc_free_omp_namelist (*head, false);
+ gfc_current_locus = old_loc;
+ *head = NULL;
+ break;
+ }
+ }
+ if (end_colon && gfc_match (" %e )", &step) != MATCH_YES)
+ {
+ gfc_free_omp_namelist (*head, false);
+ gfc_current_locus = old_loc;
+ *head = NULL;
+ break;
+ }
+ else if (!end_colon)
+ {
+ step = gfc_get_constant_expr (BT_INTEGER,
+ gfc_default_integer_kind,
+ &old_loc);
+ mpz_set_si (step->value.integer, 1);
+ }
+ (*head)->expr = step;
+ if (linear_op != OMP_LINEAR_DEFAULT)
+ for (gfc_omp_namelist *n = *head; n; n = n->next)
+ n->u.linear_op = linear_op;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_LINK)
+ && openacc
+ && (gfc_match_oacc_clause_link ("link (",
+ &c->lists[OMP_LIST_LINK])
+ == MATCH_YES))
+ continue;
+ else if ((mask & OMP_CLAUSE_LINK)
+ && !openacc
+ && (gfc_match_omp_to_link ("link (",
+ &c->lists[OMP_LIST_LINK])
+ == MATCH_YES))
+ continue;
+ break;
+ case 'm':
+ if ((mask & OMP_CLAUSE_MAP)
+ && gfc_match ("map ( ") == MATCH_YES)
+ {
+ locus old_loc2 = gfc_current_locus;
+ int always_modifier = 0;
+ int close_modifier = 0;
+ locus second_always_locus = old_loc2;
+ locus second_close_locus = old_loc2;
+
+ for (;;)
+ {
+ locus current_locus = gfc_current_locus;
+ if (gfc_match ("always ") == MATCH_YES)
+ {
+ if (always_modifier++ == 1)
+ second_always_locus = current_locus;
+ }
+ else if (gfc_match ("close ") == MATCH_YES)
+ {
+ if (close_modifier++ == 1)
+ second_close_locus = current_locus;
+ }
+ else
+ break;
+ gfc_match (", ");
+ }
+
+ gfc_omp_map_op map_op = OMP_MAP_TOFROM;
+ if (gfc_match ("alloc : ") == MATCH_YES)
+ map_op = OMP_MAP_ALLOC;
+ else if (gfc_match ("tofrom : ") == MATCH_YES)
+ map_op = always_modifier ? OMP_MAP_ALWAYS_TOFROM : OMP_MAP_TOFROM;
+ else if (gfc_match ("to : ") == MATCH_YES)
+ map_op = always_modifier ? OMP_MAP_ALWAYS_TO : OMP_MAP_TO;
+ else if (gfc_match ("from : ") == MATCH_YES)
+ map_op = always_modifier ? OMP_MAP_ALWAYS_FROM : OMP_MAP_FROM;
+ else if (gfc_match ("release : ") == MATCH_YES)
+ map_op = OMP_MAP_RELEASE;
+ else if (gfc_match ("delete : ") == MATCH_YES)
+ map_op = OMP_MAP_DELETE;
+ else
+ {
+ gfc_current_locus = old_loc2;
+ always_modifier = 0;
+ close_modifier = 0;
+ }
+
+ if (always_modifier > 1)
+ {
+ gfc_error ("too many %<always%> modifiers at %L",
+ &second_always_locus);
+ break;
+ }
+ if (close_modifier > 1)
+ {
+ gfc_error ("too many %<close%> modifiers at %L",
+ &second_close_locus);
+ break;
+ }
+
+ head = NULL;
+ if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP],
+ false, NULL, &head,
+ true, true) == MATCH_YES)
+ {
+ gfc_omp_namelist *n;
+ for (n = *head; n; n = n->next)
+ n->u.map_op = map_op;
+ continue;
+ }
+ gfc_current_locus = old_loc;
+ break;
+ }
+ if ((mask & OMP_CLAUSE_MERGEABLE)
+ && (m = gfc_match_dupl_check (!c->mergeable, "mergeable"))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->mergeable = needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_MESSAGE)
+ && (m = gfc_match_dupl_check (!c->message, "message", true,
+ &c->message)) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ continue;
+ }
+ break;
+ case 'n':
+ if ((mask & OMP_CLAUSE_NO_CREATE)
+ && gfc_match ("no_create ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_IF_PRESENT, true,
+ allow_derived))
+ continue;
+ if ((mask & OMP_CLAUSE_NOGROUP)
+ && (m = gfc_match_dupl_check (!c->nogroup, "nogroup"))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->nogroup = needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_NOHOST)
+ && (m = gfc_match_dupl_check (!c->nohost, "nohost")) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->nohost = needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_NOTEMPORAL)
+ && gfc_match_omp_variable_list ("nontemporal (",
+ &c->lists[OMP_LIST_NONTEMPORAL],
+ true) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_NOTINBRANCH)
+ && (m = gfc_match_dupl_check (!c->notinbranch && !c->inbranch,
+ "notinbranch")) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->notinbranch = needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_NOWAIT)
+ && (m = gfc_match_dupl_check (!c->nowait, "nowait")) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->nowait = needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_NUM_GANGS)
+ && (m = gfc_match_dupl_check (!c->num_gangs_expr, "num_gangs",
+ true)) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ if (gfc_match (" %e )", &c->num_gangs_expr) != MATCH_YES)
+ goto error;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_NUM_TASKS)
+ && (m = gfc_match_dupl_check (!c->num_tasks, "num_tasks", true))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ if (gfc_match ("strict : ") == MATCH_YES)
+ c->num_tasks_strict = true;
+ if (gfc_match (" %e )", &c->num_tasks) != MATCH_YES)
+ goto error;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_NUM_TEAMS)
+ && (m = gfc_match_dupl_check (!c->num_teams_upper, "num_teams",
+ true)) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ if (gfc_match ("%e ", &c->num_teams_upper) != MATCH_YES)
+ goto error;
+ if (gfc_peek_ascii_char () == ':')
+ {
+ c->num_teams_lower = c->num_teams_upper;
+ c->num_teams_upper = NULL;
+ if (gfc_match (": %e ", &c->num_teams_upper) != MATCH_YES)
+ goto error;
+ }
+ if (gfc_match (") ") != MATCH_YES)
+ goto error;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_NUM_THREADS)
+ && (m = gfc_match_dupl_check (!c->num_threads, "num_threads", true,
+ &c->num_threads)) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_NUM_WORKERS)
+ && (m = gfc_match_dupl_check (!c->num_workers_expr, "num_workers",
+ true, &c->num_workers_expr))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ continue;
+ }
+ break;
+ case 'o':
+ if ((mask & OMP_CLAUSE_ORDER)
+ && (m = gfc_match_dupl_check (!c->order_concurrent, "order ("))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ if (gfc_match (" reproducible : concurrent )") == MATCH_YES)
+ c->order_reproducible = true;
+ else if (gfc_match (" concurrent )") == MATCH_YES)
+ ;
+ else if (gfc_match (" unconstrained : concurrent )") == MATCH_YES)
+ c->order_unconstrained = true;
+ else
+ {
+ gfc_error ("Expected ORDER(CONCURRENT) at %C "
+ "with optional %<reproducible%> or "
+ "%<unconstrained%> modifier");
+ goto error;
+ }
+ c->order_concurrent = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_ORDERED)
+ && (m = gfc_match_dupl_check (!c->ordered, "ordered"))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ gfc_expr *cexpr = NULL;
+ m = gfc_match (" ( %e )", &cexpr);
+
+ c->ordered = true;
+ if (m == MATCH_YES)
+ {
+ int ordered = 0;
+ if (gfc_extract_int (cexpr, &ordered, -1))
+ ordered = 0;
+ else if (ordered <= 0)
+ {
+ gfc_error_now ("ORDERED clause argument not"
+ " constant positive integer at %C");
+ ordered = 0;
+ }
+ c->orderedc = ordered;
+ gfc_free_expr (cexpr);
+ continue;
+ }
+
+ needs_space = true;
+ continue;
+ }
+ break;
+ case 'p':
+ if ((mask & OMP_CLAUSE_COPY)
+ && gfc_match ("pcopy ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_TOFROM, true, allow_derived))
+ continue;
+ if ((mask & OMP_CLAUSE_COPYIN)
+ && gfc_match ("pcopyin ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_TO, true, allow_derived))
+ continue;
+ if ((mask & OMP_CLAUSE_COPYOUT)
+ && gfc_match ("pcopyout ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_FROM, true, allow_derived))
+ continue;
+ if ((mask & OMP_CLAUSE_CREATE)
+ && gfc_match ("pcreate ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_ALLOC, true, allow_derived))
+ continue;
+ if ((mask & OMP_CLAUSE_PRESENT)
+ && gfc_match ("present ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_FORCE_PRESENT, false,
+ allow_derived))
+ continue;
+ if ((mask & OMP_CLAUSE_COPY)
+ && gfc_match ("present_or_copy ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_TOFROM, true,
+ allow_derived))
+ continue;
+ if ((mask & OMP_CLAUSE_COPYIN)
+ && gfc_match ("present_or_copyin ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_TO, true, allow_derived))
+ continue;
+ if ((mask & OMP_CLAUSE_COPYOUT)
+ && gfc_match ("present_or_copyout ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_FROM, true, allow_derived))
+ continue;
+ if ((mask & OMP_CLAUSE_CREATE)
+ && gfc_match ("present_or_create ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_ALLOC, true, allow_derived))
+ continue;
+ if ((mask & OMP_CLAUSE_PRIORITY)
+ && (m = gfc_match_dupl_check (!c->priority, "priority", true,
+ &c->priority)) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_PRIVATE)
+ && gfc_match_omp_variable_list ("private (",
+ &c->lists[OMP_LIST_PRIVATE],
+ true) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_PROC_BIND)
+ && (m = gfc_match_dupl_check ((c->proc_bind
+ == OMP_PROC_BIND_UNKNOWN),
+ "proc_bind", true)) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ if (gfc_match ("primary )") == MATCH_YES)
+ c->proc_bind = OMP_PROC_BIND_PRIMARY;
+ else if (gfc_match ("master )") == MATCH_YES)
+ c->proc_bind = OMP_PROC_BIND_MASTER;
+ else if (gfc_match ("spread )") == MATCH_YES)
+ c->proc_bind = OMP_PROC_BIND_SPREAD;
+ else if (gfc_match ("close )") == MATCH_YES)
+ c->proc_bind = OMP_PROC_BIND_CLOSE;
+ else
+ goto error;
+ continue;
+ }
+ break;
+ case 'r':
+ if ((mask & OMP_CLAUSE_ATOMIC)
+ && (m = gfc_match_dupl_atomic ((c->atomic_op
+ == GFC_OMP_ATOMIC_UNSET),
+ "read")) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->atomic_op = GFC_OMP_ATOMIC_READ;
+ needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_REDUCTION)
+ && gfc_match_omp_clause_reduction (pc, c, openacc,
+ allow_derived) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_MEMORDER)
+ && (m = gfc_match_dupl_memorder ((c->memorder
+ == OMP_MEMORDER_UNSET),
+ "relaxed")) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->memorder = OMP_MEMORDER_RELAXED;
+ needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_MEMORDER)
+ && (m = gfc_match_dupl_memorder ((c->memorder
+ == OMP_MEMORDER_UNSET),
+ "release")) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->memorder = OMP_MEMORDER_RELEASE;
+ needs_space = true;
+ continue;
+ }
+ break;
+ case 's':
+ if ((mask & OMP_CLAUSE_SAFELEN)
+ && (m = gfc_match_dupl_check (!c->safelen_expr, "safelen",
+ true, &c->safelen_expr))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_SCHEDULE)
+ && (m = gfc_match_dupl_check (c->sched_kind == OMP_SCHED_NONE,
+ "schedule", true)) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ int nmodifiers = 0;
+ locus old_loc2 = gfc_current_locus;
+ do
+ {
+ if (gfc_match ("simd") == MATCH_YES)
+ {
+ c->sched_simd = true;
+ nmodifiers++;
+ }
+ else if (gfc_match ("monotonic") == MATCH_YES)
+ {
+ c->sched_monotonic = true;
+ nmodifiers++;
+ }
+ else if (gfc_match ("nonmonotonic") == MATCH_YES)
+ {
+ c->sched_nonmonotonic = true;
+ nmodifiers++;
+ }
+ else
+ {
+ if (nmodifiers)
+ gfc_current_locus = old_loc2;
+ break;
+ }
+ if (nmodifiers == 1
+ && gfc_match (" , ") == MATCH_YES)
+ continue;
+ else if (gfc_match (" : ") == MATCH_YES)
+ break;
+ gfc_current_locus = old_loc2;
+ break;
+ }
+ while (1);
+ if (gfc_match ("static") == MATCH_YES)
+ c->sched_kind = OMP_SCHED_STATIC;
+ else if (gfc_match ("dynamic") == MATCH_YES)
+ c->sched_kind = OMP_SCHED_DYNAMIC;
+ else if (gfc_match ("guided") == MATCH_YES)
+ c->sched_kind = OMP_SCHED_GUIDED;
+ else if (gfc_match ("runtime") == MATCH_YES)
+ c->sched_kind = OMP_SCHED_RUNTIME;
+ else if (gfc_match ("auto") == MATCH_YES)
+ c->sched_kind = OMP_SCHED_AUTO;
+ if (c->sched_kind != OMP_SCHED_NONE)
+ {
+ m = MATCH_NO;
+ if (c->sched_kind != OMP_SCHED_RUNTIME
+ && c->sched_kind != OMP_SCHED_AUTO)
+ m = gfc_match (" , %e )", &c->chunk_size);
+ if (m != MATCH_YES)
+ m = gfc_match_char (')');
+ if (m != MATCH_YES)
+ c->sched_kind = OMP_SCHED_NONE;
+ }
+ if (c->sched_kind != OMP_SCHED_NONE)
+ continue;
+ else
+ gfc_current_locus = old_loc;
+ }
+ if ((mask & OMP_CLAUSE_HOST_SELF)
+ && gfc_match ("self ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_FORCE_FROM, true,
+ allow_derived))
+ continue;
+ if ((mask & OMP_CLAUSE_SEQ)
+ && (m = gfc_match_dupl_check (!c->seq, "seq")) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->seq = true;
+ needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_MEMORDER)
+ && (m = gfc_match_dupl_memorder ((c->memorder
+ == OMP_MEMORDER_UNSET),
+ "seq_cst")) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->memorder = OMP_MEMORDER_SEQ_CST;
+ needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_SHARED)
+ && gfc_match_omp_variable_list ("shared (",
+ &c->lists[OMP_LIST_SHARED],
+ true) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_SIMDLEN)
+ && (m = gfc_match_dupl_check (!c->simdlen_expr, "simdlen", true,
+ &c->simdlen_expr)) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_SIMD)
+ && (m = gfc_match_dupl_check (!c->simd, "simd")) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->simd = needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_SEVERITY)
+ && (m = gfc_match_dupl_check (!c->severity, "severity", true))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ if (gfc_match ("fatal )") == MATCH_YES)
+ c->severity = OMP_SEVERITY_FATAL;
+ else if (gfc_match ("warning )") == MATCH_YES)
+ c->severity = OMP_SEVERITY_WARNING;
+ else
+ {
+ gfc_error ("Expected FATAL or WARNING in SEVERITY clause "
+ "at %C");
+ goto error;
+ }
+ continue;
+ }
+ break;
+ case 't':
+ if ((mask & OMP_CLAUSE_TASK_REDUCTION)
+ && gfc_match_omp_clause_reduction (pc, c, openacc,
+ allow_derived) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_THREAD_LIMIT)
+ && (m = gfc_match_dupl_check (!c->thread_limit, "thread_limit",
+ true, &c->thread_limit))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_THREADS)
+ && (m = gfc_match_dupl_check (!c->threads, "threads"))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->threads = needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_TILE)
+ && !c->tile_list
+ && match_oacc_expr_list ("tile (", &c->tile_list,
+ true) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK))
+ {
+ if (gfc_match_omp_to_link ("to (", &c->lists[OMP_LIST_TO])
+ == MATCH_YES)
+ continue;
+ }
+ else if ((mask & OMP_CLAUSE_TO)
+ && gfc_match_omp_variable_list ("to (",
+ &c->lists[OMP_LIST_TO], false,
+ NULL, &head, true) == MATCH_YES)
+ continue;
+ break;
+ case 'u':
+ if ((mask & OMP_CLAUSE_UNIFORM)
+ && gfc_match_omp_variable_list ("uniform (",
+ &c->lists[OMP_LIST_UNIFORM],
+ false) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_UNTIED)
+ && (m = gfc_match_dupl_check (!c->untied, "untied")) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->untied = needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_ATOMIC)
+ && (m = gfc_match_dupl_atomic ((c->atomic_op
+ == GFC_OMP_ATOMIC_UNSET),
+ "update")) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
+ needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_USE_DEVICE)
+ && gfc_match_omp_variable_list ("use_device (",
+ &c->lists[OMP_LIST_USE_DEVICE],
+ true) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_USE_DEVICE_PTR)
+ && gfc_match_omp_variable_list
+ ("use_device_ptr (",
+ &c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR)
+ && gfc_match_omp_variable_list
+ ("use_device_addr (",
+ &c->lists[OMP_LIST_USE_DEVICE_ADDR], false) == MATCH_YES)
+ continue;
+ break;
+ case 'v':
+ /* VECTOR_LENGTH must be matched before VECTOR, because the latter
+ doesn't unconditionally match '('. */
+ if ((mask & OMP_CLAUSE_VECTOR_LENGTH)
+ && (m = gfc_match_dupl_check (!c->vector_length_expr,
+ "vector_length", true,
+ &c->vector_length_expr))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_VECTOR)
+ && (m = gfc_match_dupl_check (!c->vector, "vector")) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->vector = true;
+ m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR);
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_NO)
+ needs_space = true;
+ continue;
+ }
+ break;
+ case 'w':
+ if ((mask & OMP_CLAUSE_WAIT)
+ && gfc_match ("wait") == MATCH_YES)
+ {
+ m = match_oacc_expr_list (" (", &c->wait_list, false);
+ if (m == MATCH_ERROR)
+ goto error;
+ else if (m == MATCH_NO)
+ {
+ gfc_expr *expr
+ = gfc_get_constant_expr (BT_INTEGER,
+ gfc_default_integer_kind,
+ &gfc_current_locus);
+ mpz_set_si (expr->value.integer, GOMP_ASYNC_NOVAL);
+ gfc_expr_list **expr_list = &c->wait_list;
+ while (*expr_list)
+ expr_list = &(*expr_list)->next;
+ *expr_list = gfc_get_expr_list ();
+ (*expr_list)->expr = expr;
+ needs_space = true;
+ }
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_WEAK)
+ && (m = gfc_match_dupl_check (!c->weak, "weak"))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->weak = true;
+ needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_WORKER)
+ && (m = gfc_match_dupl_check (!c->worker, "worker")) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->worker = true;
+ m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER);
+ if (m == MATCH_ERROR)
+ goto error;
+ else if (m == MATCH_NO)
+ needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_ATOMIC)
+ && (m = gfc_match_dupl_atomic ((c->atomic_op
+ == GFC_OMP_ATOMIC_UNSET),
+ "write")) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->atomic_op = GFC_OMP_ATOMIC_WRITE;
+ needs_space = true;
+ continue;
+ }
+ break;
+ }
+ break;
+ }
+
+end:
+ if (error
+ || (context_selector && gfc_peek_ascii_char () != ')')
+ || (!context_selector && gfc_match_omp_eos () != MATCH_YES))
+ {
+ if (!gfc_error_flag_test ())
+ gfc_error ("Failed to match clause at %C");
+ gfc_free_omp_clauses (c);
+ return MATCH_ERROR;
+ }
+
+ *cp = c;
+ return MATCH_YES;
+
+error:
+ error = true;
+ goto end;
+}
+
+
+#define OACC_PARALLEL_CLAUSES \
+ (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
+ | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
+ | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
+ | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
+ | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
+ | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH)
+#define OACC_KERNELS_CLAUSES \
+ (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
+ | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \
+ | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
+ | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
+ | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH)
+#define OACC_SERIAL_CLAUSES \
+ (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION \
+ | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
+ | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
+ | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
+ | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH)
+#define OACC_DATA_CLAUSES \
+ (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
+ | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
+ | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH)
+#define OACC_LOOP_CLAUSES \
+ (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
+ | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
+ | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \
+ | OMP_CLAUSE_TILE)
+#define OACC_PARALLEL_LOOP_CLAUSES \
+ (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
+#define OACC_KERNELS_LOOP_CLAUSES \
+ (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
+#define OACC_SERIAL_LOOP_CLAUSES \
+ (OACC_LOOP_CLAUSES | OACC_SERIAL_CLAUSES)
+#define OACC_HOST_DATA_CLAUSES \
+ (omp_mask (OMP_CLAUSE_USE_DEVICE) \
+ | OMP_CLAUSE_IF \
+ | OMP_CLAUSE_IF_PRESENT)
+#define OACC_DECLARE_CLAUSES \
+ (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
+ | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \
+ | OMP_CLAUSE_PRESENT \
+ | OMP_CLAUSE_LINK)
+#define OACC_UPDATE_CLAUSES \
+ (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST_SELF \
+ | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT)
+#define OACC_ENTER_DATA_CLAUSES \
+ (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
+ | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH)
+#define OACC_EXIT_DATA_CLAUSES \
+ (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
+ | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \
+ | OMP_CLAUSE_DETACH)
+#define OACC_WAIT_CLAUSES \
+ omp_mask (OMP_CLAUSE_ASYNC)
+#define OACC_ROUTINE_CLAUSES \
+ (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \
+ | OMP_CLAUSE_SEQ \
+ | OMP_CLAUSE_NOHOST)
+
+
+static match
+match_acc (gfc_exec_op op, const omp_mask mask)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match_omp_clauses (&c, mask, false, false, true) != MATCH_YES)
+ return MATCH_ERROR;
+ new_st.op = op;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+match
+gfc_match_oacc_parallel_loop (void)
+{
+ return match_acc (EXEC_OACC_PARALLEL_LOOP, OACC_PARALLEL_LOOP_CLAUSES);
+}
+
+
+match
+gfc_match_oacc_parallel (void)
+{
+ return match_acc (EXEC_OACC_PARALLEL, OACC_PARALLEL_CLAUSES);
+}
+
+
+match
+gfc_match_oacc_kernels_loop (void)
+{
+ return match_acc (EXEC_OACC_KERNELS_LOOP, OACC_KERNELS_LOOP_CLAUSES);
+}
+
+
+match
+gfc_match_oacc_kernels (void)
+{
+ return match_acc (EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES);
+}
+
+
+match
+gfc_match_oacc_serial_loop (void)
+{
+ return match_acc (EXEC_OACC_SERIAL_LOOP, OACC_SERIAL_LOOP_CLAUSES);
+}
+
+
+match
+gfc_match_oacc_serial (void)
+{
+ return match_acc (EXEC_OACC_SERIAL, OACC_SERIAL_CLAUSES);
+}
+
+
+match
+gfc_match_oacc_data (void)
+{
+ return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES);
+}
+
+
+match
+gfc_match_oacc_host_data (void)
+{
+ return match_acc (EXEC_OACC_HOST_DATA, OACC_HOST_DATA_CLAUSES);
+}
+
+
+match
+gfc_match_oacc_loop (void)
+{
+ return match_acc (EXEC_OACC_LOOP, OACC_LOOP_CLAUSES);
+}
+
+
+match
+gfc_match_oacc_declare (void)
+{
+ gfc_omp_clauses *c;
+ gfc_omp_namelist *n;
+ gfc_namespace *ns = gfc_current_ns;
+ gfc_oacc_declare *new_oc;
+ bool module_var = false;
+ locus where = gfc_current_locus;
+
+ if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true)
+ != MATCH_YES)
+ return MATCH_ERROR;
+
+ for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next)
+ n->sym->attr.oacc_declare_device_resident = 1;
+
+ for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next)
+ n->sym->attr.oacc_declare_link = 1;
+
+ for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next)
+ {
+ gfc_symbol *s = n->sym;
+
+ if (gfc_current_ns->proc_name
+ && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+ {
+ if (n->u.map_op != OMP_MAP_ALLOC && n->u.map_op != OMP_MAP_TO)
+ {
+ gfc_error ("Invalid clause in module with !$ACC DECLARE at %L",
+ &where);
+ return MATCH_ERROR;
+ }
+
+ module_var = true;
+ }
+
+ if (s->attr.use_assoc)
+ {
+ gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L",
+ &where);
+ return MATCH_ERROR;
+ }
+
+ if ((s->result == s && s->ns->contained != gfc_current_ns)
+ || ((s->attr.flavor == FL_UNKNOWN || s->attr.flavor == FL_VARIABLE)
+ && s->ns != gfc_current_ns))
+ {
+ gfc_error ("Variable %qs shall be declared in the same scoping unit "
+ "as !$ACC DECLARE at %L", s->name, &where);
+ return MATCH_ERROR;
+ }
+
+ if ((s->attr.dimension || s->attr.codimension)
+ && s->attr.dummy && s->as->type != AS_EXPLICIT)
+ {
+ gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L",
+ &where);
+ return MATCH_ERROR;
+ }
+
+ switch (n->u.map_op)
+ {
+ case OMP_MAP_FORCE_ALLOC:
+ case OMP_MAP_ALLOC:
+ s->attr.oacc_declare_create = 1;
+ break;
+
+ case OMP_MAP_FORCE_TO:
+ case OMP_MAP_TO:
+ s->attr.oacc_declare_copyin = 1;
+ break;
+
+ case OMP_MAP_FORCE_DEVICEPTR:
+ s->attr.oacc_declare_deviceptr = 1;
+ break;
+
+ default:
+ break;
+ }
+ }
+
+ new_oc = gfc_get_oacc_declare ();
+ new_oc->next = ns->oacc_declare;
+ new_oc->module_var = module_var;
+ new_oc->clauses = c;
+ new_oc->loc = gfc_current_locus;
+ ns->oacc_declare = new_oc;
+
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_oacc_update (void)
+{
+ gfc_omp_clauses *c;
+ locus here = gfc_current_locus;
+
+ if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true)
+ != MATCH_YES)
+ return MATCH_ERROR;
+
+ if (!c->lists[OMP_LIST_MAP])
+ {
+ gfc_error ("%<acc update%> must contain at least one "
+ "%<device%> or %<host%> or %<self%> clause at %L", &here);
+ return MATCH_ERROR;
+ }
+
+ new_st.op = EXEC_OACC_UPDATE;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_oacc_enter_data (void)
+{
+ return match_acc (EXEC_OACC_ENTER_DATA, OACC_ENTER_DATA_CLAUSES);
+}
+
+
+match
+gfc_match_oacc_exit_data (void)
+{
+ return match_acc (EXEC_OACC_EXIT_DATA, OACC_EXIT_DATA_CLAUSES);
+}
+
+
+match
+gfc_match_oacc_wait (void)
+{
+ gfc_omp_clauses *c = gfc_get_omp_clauses ();
+ gfc_expr_list *wait_list = NULL, *el;
+ bool space = true;
+ match m;
+
+ m = match_oacc_expr_list (" (", &wait_list, true);
+ if (m == MATCH_ERROR)
+ return m;
+ else if (m == MATCH_YES)
+ space = false;
+
+ if (gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, space, space, true)
+ == MATCH_ERROR)
+ return MATCH_ERROR;
+
+ if (wait_list)
+ for (el = wait_list; el; el = el->next)
+ {
+ if (el->expr == NULL)
+ {
+ gfc_error ("Invalid argument to !$ACC WAIT at %C");
+ return MATCH_ERROR;
+ }
+
+ if (!gfc_resolve_expr (el->expr)
+ || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0)
+ {
+ gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
+ &el->expr->where);
+
+ return MATCH_ERROR;
+ }
+ }
+ c->wait_list = wait_list;
+ new_st.op = EXEC_OACC_WAIT;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_oacc_cache (void)
+{
+ gfc_omp_clauses *c = gfc_get_omp_clauses ();
+ /* The OpenACC cache directive explicitly only allows "array elements or
+ subarrays", which we're currently not checking here. Either check this
+ after the call of gfc_match_omp_variable_list, or add something like a
+ only_sections variant next to its allow_sections parameter. */
+ match m = gfc_match_omp_variable_list (" (",
+ &c->lists[OMP_LIST_CACHE], true,
+ NULL, NULL, true);
+ if (m != MATCH_YES)
+ {
+ gfc_free_omp_clauses(c);
+ return m;
+ }
+
+ if (gfc_current_state() != COMP_DO
+ && gfc_current_state() != COMP_DO_CONCURRENT)
+ {
+ gfc_error ("ACC CACHE directive must be inside of loop %C");
+ gfc_free_omp_clauses(c);
+ return MATCH_ERROR;
+ }
+
+ new_st.op = EXEC_OACC_CACHE;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+/* Determine the OpenACC 'routine' directive's level of parallelism. */
+
+static oacc_routine_lop
+gfc_oacc_routine_lop (gfc_omp_clauses *clauses)
+{
+ oacc_routine_lop ret = OACC_ROUTINE_LOP_SEQ;
+
+ if (clauses)
+ {
+ unsigned n_lop_clauses = 0;
+
+ if (clauses->gang)
+ {
+ ++n_lop_clauses;
+ ret = OACC_ROUTINE_LOP_GANG;
+ }
+ if (clauses->worker)
+ {
+ ++n_lop_clauses;
+ ret = OACC_ROUTINE_LOP_WORKER;
+ }
+ if (clauses->vector)
+ {
+ ++n_lop_clauses;
+ ret = OACC_ROUTINE_LOP_VECTOR;
+ }
+ if (clauses->seq)
+ {
+ ++n_lop_clauses;
+ ret = OACC_ROUTINE_LOP_SEQ;
+ }
+
+ if (n_lop_clauses > 1)
+ ret = OACC_ROUTINE_LOP_ERROR;
+ }
+
+ return ret;
+}
+
+match
+gfc_match_oacc_routine (void)
+{
+ locus old_loc;
+ match m;
+ gfc_intrinsic_sym *isym = NULL;
+ gfc_symbol *sym = NULL;
+ gfc_omp_clauses *c = NULL;
+ gfc_oacc_routine_name *n = NULL;
+ oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE;
+ bool nohost;
+
+ old_loc = gfc_current_locus;
+
+ m = gfc_match (" (");
+
+ if (gfc_current_ns->proc_name
+ && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
+ && m == MATCH_YES)
+ {
+ gfc_error ("Only the !$ACC ROUTINE form without "
+ "list is allowed in interface block at %C");
+ goto cleanup;
+ }
+
+ if (m == MATCH_YES)
+ {
+ char buffer[GFC_MAX_SYMBOL_LEN + 1];
+
+ m = gfc_match_name (buffer);
+ if (m == MATCH_YES)
+ {
+ gfc_symtree *st = NULL;
+
+ /* First look for an intrinsic symbol. */
+ isym = gfc_find_function (buffer);
+ if (!isym)
+ isym = gfc_find_subroutine (buffer);
+ /* If no intrinsic symbol found, search the current namespace. */
+ if (!isym)
+ st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
+ if (st)
+ {
+ sym = st->n.sym;
+ /* If the name in a 'routine' directive refers to the containing
+ subroutine or function, then make sure that we'll later handle
+ this accordingly. */
+ if (gfc_current_ns->proc_name != NULL
+ && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
+ sym = NULL;
+ }
+
+ if (isym == NULL && st == NULL)
+ {
+ gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C",
+ buffer);
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+ }
+ }
+ else
+ {
+ gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match_char (')') != MATCH_YES)
+ {
+ gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
+ " ')' after NAME");
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+ }
+ }
+
+ if (gfc_match_omp_eos () != MATCH_YES
+ && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true)
+ != MATCH_YES))
+ return MATCH_ERROR;
+
+ lop = gfc_oacc_routine_lop (c);
+ if (lop == OACC_ROUTINE_LOP_ERROR)
+ {
+ gfc_error ("Multiple loop axes specified for routine at %C");
+ goto cleanup;
+ }
+ nohost = c ? c->nohost : false;
+
+ if (isym != NULL)
+ {
+ /* Diagnose any OpenACC 'routine' directive that doesn't match the
+ (implicit) one with a 'seq' clause. */
+ if (c && (c->gang || c->worker || c->vector))
+ {
+ gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
+ " at %C marked with incompatible GANG, WORKER, or VECTOR"
+ " clause");
+ goto cleanup;
+ }
+ /* ..., and no 'nohost' clause. */
+ if (nohost)
+ {
+ gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
+ " at %C marked with incompatible NOHOST clause");
+ goto cleanup;
+ }
+ }
+ else if (sym != NULL)
+ {
+ bool add = true;
+
+ /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
+ match the first one. */
+ for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names;
+ n_p;
+ n_p = n_p->next)
+ if (n_p->sym == sym)
+ {
+ add = false;
+ bool nohost_p = n_p->clauses ? n_p->clauses->nohost : false;
+ if (lop != gfc_oacc_routine_lop (n_p->clauses)
+ || nohost != nohost_p)
+ {
+ gfc_error ("!$ACC ROUTINE already applied at %C");
+ goto cleanup;
+ }
+ }
+
+ if (add)
+ {
+ sym->attr.oacc_routine_lop = lop;
+ sym->attr.oacc_routine_nohost = nohost;
+
+ n = gfc_get_oacc_routine_name ();
+ n->sym = sym;
+ n->clauses = c;
+ n->next = gfc_current_ns->oacc_routine_names;
+ n->loc = old_loc;
+ gfc_current_ns->oacc_routine_names = n;
+ }
+ }
+ else if (gfc_current_ns->proc_name)
+ {
+ /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
+ match the first one. */
+ oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop;
+ bool nohost_p = gfc_current_ns->proc_name->attr.oacc_routine_nohost;
+ if (lop_p != OACC_ROUTINE_LOP_NONE
+ && (lop != lop_p
+ || nohost != nohost_p))
+ {
+ gfc_error ("!$ACC ROUTINE already applied at %C");
+ goto cleanup;
+ }
+
+ if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
+ gfc_current_ns->proc_name->name,
+ &old_loc))
+ goto cleanup;
+ gfc_current_ns->proc_name->attr.oacc_routine_lop = lop;
+ gfc_current_ns->proc_name->attr.oacc_routine_nohost = nohost;
+ }
+ else
+ /* Something has gone wrong, possibly a syntax error. */
+ goto cleanup;
+
+ if (gfc_pure (NULL) && c && (c->gang || c->worker || c->vector))
+ {
+ gfc_error ("!$ACC ROUTINE with GANG, WORKER, or VECTOR clause is not "
+ "permitted in PURE procedure at %C");
+ goto cleanup;
+ }
+
+
+ if (n)
+ n->clauses = c;
+ else if (gfc_current_ns->oacc_routine)
+ gfc_current_ns->oacc_routine_clauses = c;
+
+ new_st.op = EXEC_OACC_ROUTINE;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+
+cleanup:
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+}
+
+
+#define OMP_PARALLEL_CLAUSES \
+ (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
+ | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \
+ | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \
+ | OMP_CLAUSE_PROC_BIND | OMP_CLAUSE_ALLOCATE)
+#define OMP_DECLARE_SIMD_CLAUSES \
+ (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \
+ | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \
+ | OMP_CLAUSE_NOTINBRANCH)
+#define OMP_DO_CLAUSES \
+ (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
+ | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
+ | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \
+ | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE)
+#define OMP_LOOP_CLAUSES \
+ (omp_mask (OMP_CLAUSE_BIND) | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_ORDER \
+ | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
+
+#define OMP_SCOPE_CLAUSES \
+ (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_REDUCTION)
+#define OMP_SECTIONS_CLAUSES \
+ (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
+ | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE)
+#define OMP_SIMD_CLAUSES \
+ (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \
+ | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \
+ | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN \
+ | OMP_CLAUSE_IF | OMP_CLAUSE_ORDER | OMP_CLAUSE_NOTEMPORAL)
+#define OMP_TASK_CLAUSES \
+ (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
+ | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \
+ | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \
+ | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_IN_REDUCTION \
+ | OMP_CLAUSE_DETACH | OMP_CLAUSE_AFFINITY | OMP_CLAUSE_ALLOCATE)
+#define OMP_TASKLOOP_CLAUSES \
+ (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
+ | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \
+ | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \
+ | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \
+ | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP \
+ | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IN_REDUCTION | OMP_CLAUSE_ALLOCATE)
+#define OMP_TASKGROUP_CLAUSES \
+ (omp_mask (OMP_CLAUSE_TASK_REDUCTION) | OMP_CLAUSE_ALLOCATE)
+#define OMP_TARGET_CLAUSES \
+ (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
+ | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \
+ | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \
+ | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION \
+ | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE)
+#define OMP_TARGET_DATA_CLAUSES \
+ (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
+ | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR)
+#define OMP_TARGET_ENTER_DATA_CLAUSES \
+ (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
+ | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
+#define OMP_TARGET_EXIT_DATA_CLAUSES \
+ (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
+ | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
+#define OMP_TARGET_UPDATE_CLAUSES \
+ (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \
+ | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
+#define OMP_TEAMS_CLAUSES \
+ (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \
+ | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
+ | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE)
+#define OMP_DISTRIBUTE_CLAUSES \
+ (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
+ | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE \
+ | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE)
+#define OMP_SINGLE_CLAUSES \
+ (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
+ | OMP_CLAUSE_ALLOCATE)
+#define OMP_ORDERED_CLAUSES \
+ (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD)
+#define OMP_DECLARE_TARGET_CLAUSES \
+ (omp_mask (OMP_CLAUSE_TO) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE)
+#define OMP_ATOMIC_CLAUSES \
+ (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \
+ | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \
+ | OMP_CLAUSE_WEAK)
+#define OMP_MASKED_CLAUSES \
+ (omp_mask (OMP_CLAUSE_FILTER))
+#define OMP_ERROR_CLAUSES \
+ (omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
+
+
+
+static match
+match_omp (gfc_exec_op op, const omp_mask mask)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match_omp_clauses (&c, mask, true, true, false, false,
+ op == EXEC_OMP_TARGET) != MATCH_YES)
+ return MATCH_ERROR;
+ new_st.op = op;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_critical (void)
+{
+ char n[GFC_MAX_SYMBOL_LEN+1];
+ gfc_omp_clauses *c = NULL;
+
+ if (gfc_match (" ( %n )", n) != MATCH_YES)
+ n[0] = '\0';
+
+ if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_HINT),
+ /* first = */ n[0] == '\0') != MATCH_YES)
+ return MATCH_ERROR;
+
+ new_st.op = EXEC_OMP_CRITICAL;
+ new_st.ext.omp_clauses = c;
+ if (n[0])
+ c->critical_name = xstrdup (n);
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_end_critical (void)
+{
+ char n[GFC_MAX_SYMBOL_LEN+1];
+
+ if (gfc_match (" ( %n )", n) != MATCH_YES)
+ n[0] = '\0';
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
+ return MATCH_ERROR;
+ }
+
+ new_st.op = EXEC_OMP_END_CRITICAL;
+ new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
+ return MATCH_YES;
+}
+
+/* depobj(depobj) depend(dep-type:loc)|destroy|update(dep-type)
+ dep-type = in/out/inout/mutexinoutset/depobj/source/sink
+ depend: !source, !sink
+ update: !source, !sink, !depobj
+ locator = exactly one list item .*/
+match
+gfc_match_omp_depobj (void)
+{
+ gfc_omp_clauses *c = NULL;
+ gfc_expr *depobj;
+
+ if (gfc_match (" ( %v ) ", &depobj) != MATCH_YES)
+ {
+ gfc_error ("Expected %<( depobj )%> at %C");
+ return MATCH_ERROR;
+ }
+ if (gfc_match ("update ( ") == MATCH_YES)
+ {
+ c = gfc_get_omp_clauses ();
+ if (gfc_match ("inout )") == MATCH_YES)
+ c->depobj_update = OMP_DEPEND_INOUT;
+ else if (gfc_match ("in )") == MATCH_YES)
+ c->depobj_update = OMP_DEPEND_IN;
+ else if (gfc_match ("out )") == MATCH_YES)
+ c->depobj_update = OMP_DEPEND_OUT;
+ else if (gfc_match ("mutexinoutset )") == MATCH_YES)
+ c->depobj_update = OMP_DEPEND_MUTEXINOUTSET;
+ else
+ {
+ gfc_error ("Expected IN, OUT, INOUT, MUTEXINOUTSET followed by "
+ "%<)%> at %C");
+ goto error;
+ }
+ }
+ else if (gfc_match ("destroy") == MATCH_YES)
+ {
+ c = gfc_get_omp_clauses ();
+ c->destroy = true;
+ }
+ else if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEPEND), true, false)
+ != MATCH_YES)
+ goto error;
+
+ if (c->depobj_update == OMP_DEPEND_UNSET && !c->destroy)
+ {
+ if (!c->depend_source && !c->lists[OMP_LIST_DEPEND])
+ {
+ gfc_error ("Expected DEPEND, UPDATE, or DESTROY clause at %C");
+ goto error;
+ }
+ if (c->depend_source
+ || c->lists[OMP_LIST_DEPEND]->u.depend_op == OMP_DEPEND_SINK_FIRST
+ || c->lists[OMP_LIST_DEPEND]->u.depend_op == OMP_DEPEND_SINK
+ || c->lists[OMP_LIST_DEPEND]->u.depend_op == OMP_DEPEND_DEPOBJ)
+ {
+ gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall not "
+ "have dependence-type SOURCE, SINK or DEPOBJ",
+ c->lists[OMP_LIST_DEPEND]
+ ? &c->lists[OMP_LIST_DEPEND]->where : &gfc_current_locus);
+ goto error;
+ }
+ if (c->lists[OMP_LIST_DEPEND]->next)
+ {
+ gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall have "
+ "only a single locator",
+ &c->lists[OMP_LIST_DEPEND]->next->where);
+ goto error;
+ }
+ }
+
+ c->depobj = depobj;
+ new_st.op = EXEC_OMP_DEPOBJ;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+
+error:
+ gfc_free_expr (depobj);
+ gfc_free_omp_clauses (c);
+ return MATCH_ERROR;
+}
+
+match
+gfc_match_omp_distribute (void)
+{
+ return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES);
+}
+
+
+match
+gfc_match_omp_distribute_parallel_do (void)
+{
+ return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO,
+ (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
+ | OMP_DO_CLAUSES)
+ & ~(omp_mask (OMP_CLAUSE_ORDERED))
+ & ~(omp_mask (OMP_CLAUSE_LINEAR)));
+}
+
+
+match
+gfc_match_omp_distribute_parallel_do_simd (void)
+{
+ return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD,
+ (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
+ | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
+ & ~(omp_mask (OMP_CLAUSE_ORDERED)));
+}
+
+
+match
+gfc_match_omp_distribute_simd (void)
+{
+ return match_omp (EXEC_OMP_DISTRIBUTE_SIMD,
+ OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
+}
+
+
+match
+gfc_match_omp_do (void)
+{
+ return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES);
+}
+
+
+match
+gfc_match_omp_do_simd (void)
+{
+ return match_omp (EXEC_OMP_DO_SIMD, OMP_DO_CLAUSES | OMP_SIMD_CLAUSES);
+}
+
+
+match
+gfc_match_omp_loop (void)
+{
+ return match_omp (EXEC_OMP_LOOP, OMP_LOOP_CLAUSES);
+}
+
+
+match
+gfc_match_omp_teams_loop (void)
+{
+ return match_omp (EXEC_OMP_TEAMS_LOOP, OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
+}
+
+
+match
+gfc_match_omp_target_teams_loop (void)
+{
+ return match_omp (EXEC_OMP_TARGET_TEAMS_LOOP,
+ OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
+}
+
+
+match
+gfc_match_omp_parallel_loop (void)
+{
+ return match_omp (EXEC_OMP_PARALLEL_LOOP,
+ OMP_PARALLEL_CLAUSES | OMP_LOOP_CLAUSES);
+}
+
+
+match
+gfc_match_omp_target_parallel_loop (void)
+{
+ return match_omp (EXEC_OMP_TARGET_PARALLEL_LOOP,
+ (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
+ | OMP_LOOP_CLAUSES));
+}
+
+
+match
+gfc_match_omp_error (void)
+{
+ locus loc = gfc_current_locus;
+ match m = match_omp (EXEC_OMP_ERROR, OMP_ERROR_CLAUSES);
+ if (m != MATCH_YES)
+ return m;
+
+ gfc_omp_clauses *c = new_st.ext.omp_clauses;
+ if (c->severity == OMP_SEVERITY_UNSET)
+ c->severity = OMP_SEVERITY_FATAL;
+ if (new_st.ext.omp_clauses->at == OMP_AT_EXECUTION)
+ return MATCH_YES;
+ if (c->message
+ && (!gfc_resolve_expr (c->message)
+ || c->message->ts.type != BT_CHARACTER
+ || c->message->ts.kind != gfc_default_character_kind
+ || c->message->rank != 0))
+ {
+ gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
+ "CHARACTER expression",
+ &new_st.ext.omp_clauses->message->where);
+ return MATCH_ERROR;
+ }
+ if (c->message && !gfc_is_constant_expr (c->message))
+ {
+ gfc_error ("Constant character expression required in MESSAGE clause "
+ "at %L", &new_st.ext.omp_clauses->message->where);
+ return MATCH_ERROR;
+ }
+ if (c->message)
+ {
+ const char *msg = G_("$OMP ERROR encountered at %L: %s");
+ gcc_assert (c->message->expr_type == EXPR_CONSTANT);
+ gfc_charlen_t slen = c->message->value.character.length;
+ int i = gfc_validate_kind (BT_CHARACTER, gfc_default_character_kind,
+ false);
+ size_t size = slen * gfc_character_kinds[i].bit_size / 8;
+ unsigned char *s = XCNEWVAR (unsigned char, size + 1);
+ gfc_encode_character (gfc_default_character_kind, slen,
+ c->message->value.character.string,
+ (unsigned char *) s, size);
+ s[size] = '\0';
+ if (c->severity == OMP_SEVERITY_WARNING)
+ gfc_warning_now (0, msg, &loc, s);
+ else
+ gfc_error_now (msg, &loc, s);
+ free (s);
+ }
+ else
+ {
+ const char *msg = G_("$OMP ERROR encountered at %L");
+ if (c->severity == OMP_SEVERITY_WARNING)
+ gfc_warning_now (0, msg, &loc);
+ else
+ gfc_error_now (msg, &loc);
+ }
+ return MATCH_YES;
+}
+
+match
+gfc_match_omp_flush (void)
+{
+ gfc_omp_namelist *list = NULL;
+ gfc_omp_clauses *c = NULL;
+ gfc_gobble_whitespace ();
+ enum gfc_omp_memorder mo = OMP_MEMORDER_UNSET;
+ if (gfc_match_omp_eos () == MATCH_NO && gfc_peek_ascii_char () != '(')
+ {
+ if (gfc_match ("seq_cst") == MATCH_YES)
+ mo = OMP_MEMORDER_SEQ_CST;
+ else if (gfc_match ("acq_rel") == MATCH_YES)
+ mo = OMP_MEMORDER_ACQ_REL;
+ else if (gfc_match ("release") == MATCH_YES)
+ mo = OMP_MEMORDER_RELEASE;
+ else if (gfc_match ("acquire") == MATCH_YES)
+ mo = OMP_MEMORDER_ACQUIRE;
+ else
+ {
+ gfc_error ("Expected SEQ_CST, AQC_REL, RELEASE, or ACQUIRE at %C");
+ return MATCH_ERROR;
+ }
+ c = gfc_get_omp_clauses ();
+ c->memorder = mo;
+ }
+ gfc_match_omp_variable_list (" (", &list, true);
+ if (list && mo != OMP_MEMORDER_UNSET)
+ {
+ gfc_error ("List specified together with memory order clause in FLUSH "
+ "directive at %C");
+ gfc_free_omp_namelist (list, false);
+ gfc_free_omp_clauses (c);
+ return MATCH_ERROR;
+ }
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
+ gfc_free_omp_namelist (list, false);
+ gfc_free_omp_clauses (c);
+ return MATCH_ERROR;
+ }
+ new_st.op = EXEC_OMP_FLUSH;
+ new_st.ext.omp_namelist = list;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_declare_simd (void)
+{
+ locus where = gfc_current_locus;
+ gfc_symbol *proc_name;
+ gfc_omp_clauses *c;
+ gfc_omp_declare_simd *ods;
+ bool needs_space = false;
+
+ switch (gfc_match (" ( %s ) ", &proc_name))
+ {
+ case MATCH_YES: break;
+ case MATCH_NO: proc_name = NULL; needs_space = true; break;
+ case MATCH_ERROR: return MATCH_ERROR;
+ }
+
+ if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true,
+ needs_space) != MATCH_YES)
+ return MATCH_ERROR;
+
+ if (gfc_current_ns->is_block_data)
+ {
+ gfc_free_omp_clauses (c);
+ return MATCH_YES;
+ }
+
+ ods = gfc_get_omp_declare_simd ();
+ ods->where = where;
+ ods->proc_name = proc_name;
+ ods->clauses = c;
+ ods->next = gfc_current_ns->omp_declare_simd;
+ gfc_current_ns->omp_declare_simd = ods;
+ return MATCH_YES;
+}
+
+
+static bool
+match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
+{
+ match m;
+ locus old_loc = gfc_current_locus;
+ char sname[GFC_MAX_SYMBOL_LEN + 1];
+ gfc_symbol *sym;
+ gfc_namespace *ns = gfc_current_ns;
+ gfc_expr *lvalue = NULL, *rvalue = NULL;
+ gfc_symtree *st;
+ gfc_actual_arglist *arglist;
+
+ m = gfc_match (" %v =", &lvalue);
+ if (m != MATCH_YES)
+ gfc_current_locus = old_loc;
+ else
+ {
+ m = gfc_match (" %e )", &rvalue);
+ if (m == MATCH_YES)
+ {
+ ns->code = gfc_get_code (EXEC_ASSIGN);
+ ns->code->expr1 = lvalue;
+ ns->code->expr2 = rvalue;
+ ns->code->loc = old_loc;
+ return true;
+ }
+
+ gfc_current_locus = old_loc;
+ gfc_free_expr (lvalue);
+ }
+
+ m = gfc_match (" %n", sname);
+ if (m != MATCH_YES)
+ return false;
+
+ if (strcmp (sname, omp_sym1->name) == 0
+ || strcmp (sname, omp_sym2->name) == 0)
+ return false;
+
+ gfc_current_ns = ns->parent;
+ if (gfc_get_ha_sym_tree (sname, &st))
+ return false;
+
+ sym = st->n.sym;
+ if (sym->attr.flavor != FL_PROCEDURE
+ && sym->attr.flavor != FL_UNKNOWN)
+ return false;
+
+ if (!sym->attr.generic
+ && !sym->attr.subroutine
+ && !sym->attr.function)
+ {
+ if (!(sym->attr.external && !sym->attr.referenced))
+ {
+ /* ...create a symbol in this scope... */
+ if (sym->ns != gfc_current_ns
+ && gfc_get_sym_tree (sname, NULL, &st, false) == 1)
+ return false;
+
+ if (sym != st->n.sym)
+ sym = st->n.sym;
+ }
+
+ /* ...and then to try to make the symbol into a subroutine. */
+ if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
+ return false;
+ }
+
+ gfc_set_sym_referenced (sym);
+ gfc_gobble_whitespace ();
+ if (gfc_peek_ascii_char () != '(')
+ return false;
+
+ gfc_current_ns = ns;
+ m = gfc_match_actual_arglist (1, &arglist);
+ if (m != MATCH_YES)
+ return false;
+
+ if (gfc_match_char (')') != MATCH_YES)
+ return false;
+
+ ns->code = gfc_get_code (EXEC_CALL);
+ ns->code->symtree = st;
+ ns->code->ext.actual = arglist;
+ ns->code->loc = old_loc;
+ return true;
+}
+
+static bool
+gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name,
+ gfc_typespec *ts, const char **n)
+{
+ if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL)
+ return false;
+
+ switch (rop)
+ {
+ case OMP_REDUCTION_PLUS:
+ case OMP_REDUCTION_MINUS:
+ case OMP_REDUCTION_TIMES:
+ return ts->type != BT_LOGICAL;
+ case OMP_REDUCTION_AND:
+ case OMP_REDUCTION_OR:
+ case OMP_REDUCTION_EQV:
+ case OMP_REDUCTION_NEQV:
+ return ts->type == BT_LOGICAL;
+ case OMP_REDUCTION_USER:
+ if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL))
+ {
+ gfc_symbol *sym;
+
+ gfc_find_symbol (name, NULL, 1, &sym);
+ if (sym != NULL)
+ {
+ if (sym->attr.intrinsic)
+ *n = sym->name;
+ else if ((sym->attr.flavor != FL_UNKNOWN
+ && sym->attr.flavor != FL_PROCEDURE)
+ || sym->attr.external
+ || sym->attr.generic
+ || sym->attr.entry
+ || sym->attr.result
+ || sym->attr.dummy
+ || sym->attr.subroutine
+ || sym->attr.pointer
+ || sym->attr.target
+ || sym->attr.cray_pointer
+ || sym->attr.cray_pointee
+ || (sym->attr.proc != PROC_UNKNOWN
+ && sym->attr.proc != PROC_INTRINSIC)
+ || sym->attr.if_source != IFSRC_UNKNOWN
+ || sym == sym->ns->proc_name)
+ *n = NULL;
+ else
+ *n = sym->name;
+ }
+ else
+ *n = name;
+ if (*n
+ && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0))
+ return true;
+ else if (*n
+ && ts->type == BT_INTEGER
+ && (strcmp (*n, "iand") == 0
+ || strcmp (*n, "ior") == 0
+ || strcmp (*n, "ieor") == 0))
+ return true;
+ }
+ break;
+ default:
+ break;
+ }
+ return false;
+}
+
+gfc_omp_udr *
+gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
+{
+ gfc_omp_udr *omp_udr;
+
+ if (st == NULL)
+ return NULL;
+
+ for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
+ if (omp_udr->ts.type == ts->type
+ || ((omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
+ && (ts->type == BT_DERIVED || ts->type == BT_CLASS)))
+ {
+ if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
+ {
+ if (strcmp (omp_udr->ts.u.derived->name, ts->u.derived->name) == 0)
+ return omp_udr;
+ }
+ else if (omp_udr->ts.kind == ts->kind)
+ {
+ if (omp_udr->ts.type == BT_CHARACTER)
+ {
+ if (omp_udr->ts.u.cl->length == NULL
+ || ts->u.cl->length == NULL)
+ return omp_udr;
+ if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+ return omp_udr;
+ if (ts->u.cl->length->expr_type != EXPR_CONSTANT)
+ return omp_udr;
+ if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER)
+ return omp_udr;
+ if (ts->u.cl->length->ts.type != BT_INTEGER)
+ return omp_udr;
+ if (gfc_compare_expr (omp_udr->ts.u.cl->length,
+ ts->u.cl->length, INTRINSIC_EQ) != 0)
+ continue;
+ }
+ return omp_udr;
+ }
+ }
+ return NULL;
+}
+
+match
+gfc_match_omp_declare_reduction (void)
+{
+ match m;
+ gfc_intrinsic_op op;
+ char name[GFC_MAX_SYMBOL_LEN + 3];
+ auto_vec<gfc_typespec, 5> tss;
+ gfc_typespec ts;
+ unsigned int i;
+ gfc_symtree *st;
+ locus where = gfc_current_locus;
+ locus end_loc = gfc_current_locus;
+ bool end_loc_set = false;
+ gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
+
+ if (gfc_match_char ('(') != MATCH_YES)
+ return MATCH_ERROR;
+
+ m = gfc_match (" %o : ", &op);
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+ if (m == MATCH_YES)
+ {
+ snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
+ rop = (gfc_omp_reduction_op) op;
+ }
+ else
+ {
+ m = gfc_match_defined_op_name (name + 1, 1);
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+ if (m == MATCH_YES)
+ {
+ name[0] = '.';
+ strcat (name, ".");
+ if (gfc_match (" : ") != MATCH_YES)
+ return MATCH_ERROR;
+ }
+ else
+ {
+ if (gfc_match (" %n : ", name) != MATCH_YES)
+ return MATCH_ERROR;
+ }
+ rop = OMP_REDUCTION_USER;
+ }
+
+ m = gfc_match_type_spec (&ts);
+ if (m != MATCH_YES)
+ return MATCH_ERROR;
+ /* Treat len=: the same as len=*. */
+ if (ts.type == BT_CHARACTER)
+ ts.deferred = false;
+ tss.safe_push (ts);
+
+ while (gfc_match_char (',') == MATCH_YES)
+ {
+ m = gfc_match_type_spec (&ts);
+ if (m != MATCH_YES)
+ return MATCH_ERROR;
+ tss.safe_push (ts);
+ }
+ if (gfc_match_char (':') != MATCH_YES)
+ return MATCH_ERROR;
+
+ st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
+ for (i = 0; i < tss.length (); i++)
+ {
+ gfc_symtree *omp_out, *omp_in;
+ gfc_symtree *omp_priv = NULL, *omp_orig = NULL;
+ gfc_namespace *combiner_ns, *initializer_ns = NULL;
+ gfc_omp_udr *prev_udr, *omp_udr;
+ const char *predef_name = NULL;
+
+ omp_udr = gfc_get_omp_udr ();
+ omp_udr->name = gfc_get_string ("%s", name);
+ omp_udr->rop = rop;
+ omp_udr->ts = tss[i];
+ omp_udr->where = where;
+
+ gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
+ combiner_ns->proc_name = combiner_ns->parent->proc_name;
+
+ gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
+ gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
+ combiner_ns->omp_udr_ns = 1;
+ omp_out->n.sym->ts = tss[i];
+ omp_in->n.sym->ts = tss[i];
+ omp_out->n.sym->attr.omp_udr_artificial_var = 1;
+ omp_in->n.sym->attr.omp_udr_artificial_var = 1;
+ omp_out->n.sym->attr.flavor = FL_VARIABLE;
+ omp_in->n.sym->attr.flavor = FL_VARIABLE;
+ gfc_commit_symbols ();
+ omp_udr->combiner_ns = combiner_ns;
+ omp_udr->omp_out = omp_out->n.sym;
+ omp_udr->omp_in = omp_in->n.sym;
+
+ locus old_loc = gfc_current_locus;
+
+ if (!match_udr_expr (omp_out, omp_in))
+ {
+ syntax:
+ gfc_current_locus = old_loc;
+ gfc_current_ns = combiner_ns->parent;
+ gfc_undo_symbols ();
+ gfc_free_omp_udr (omp_udr);
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match (" initializer ( ") == MATCH_YES)
+ {
+ gfc_current_ns = combiner_ns->parent;
+ initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
+ gfc_current_ns = initializer_ns;
+ initializer_ns->proc_name = initializer_ns->parent->proc_name;
+
+ gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
+ gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
+ initializer_ns->omp_udr_ns = 1;
+ omp_priv->n.sym->ts = tss[i];
+ omp_orig->n.sym->ts = tss[i];
+ omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
+ omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
+ omp_priv->n.sym->attr.flavor = FL_VARIABLE;
+ omp_orig->n.sym->attr.flavor = FL_VARIABLE;
+ gfc_commit_symbols ();
+ omp_udr->initializer_ns = initializer_ns;
+ omp_udr->omp_priv = omp_priv->n.sym;
+ omp_udr->omp_orig = omp_orig->n.sym;
+
+ if (!match_udr_expr (omp_priv, omp_orig))
+ goto syntax;
+ }
+
+ gfc_current_ns = combiner_ns->parent;
+ if (!end_loc_set)
+ {
+ end_loc_set = true;
+ end_loc = gfc_current_locus;
+ }
+ gfc_current_locus = old_loc;
+
+ prev_udr = gfc_omp_udr_find (st, &tss[i]);
+ if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name)
+ /* Don't error on !$omp declare reduction (min : integer : ...)
+ just yet, there could be integer :: min afterwards,
+ making it valid. When the UDR is resolved, we'll get
+ to it again. */
+ && (rop != OMP_REDUCTION_USER || name[0] == '.'))
+ {
+ if (predef_name)
+ gfc_error_now ("Redefinition of predefined %s "
+ "!$OMP DECLARE REDUCTION at %L",
+ predef_name, &where);
+ else
+ gfc_error_now ("Redefinition of predefined "
+ "!$OMP DECLARE REDUCTION at %L", &where);
+ }
+ else if (prev_udr)
+ {
+ gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L",
+ &where);
+ gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L",
+ &prev_udr->where);
+ }
+ else if (st)
+ {
+ omp_udr->next = st->n.omp_udr;
+ st->n.omp_udr = omp_udr;
+ }
+ else
+ {
+ st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
+ st->n.omp_udr = omp_udr;
+ }
+ }
+
+ if (end_loc_set)
+ {
+ gfc_current_locus = end_loc;
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C");
+ gfc_current_locus = where;
+ return MATCH_ERROR;
+ }
+
+ return MATCH_YES;
+ }
+ gfc_clear_error ();
+ return MATCH_ERROR;
+}
+
+
+match
+gfc_match_omp_declare_target (void)
+{
+ locus old_loc;
+ match m;
+ gfc_omp_clauses *c = NULL;
+ int list;
+ gfc_omp_namelist *n;
+ gfc_symbol *s;
+
+ old_loc = gfc_current_locus;
+
+ if (gfc_current_ns->proc_name
+ && gfc_match_omp_eos () == MATCH_YES)
+ {
+ if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
+ gfc_current_ns->proc_name->name,
+ &old_loc))
+ goto cleanup;
+ return MATCH_YES;
+ }
+
+ if (gfc_current_ns->proc_name
+ && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
+ {
+ gfc_error ("Only the !$OMP DECLARE TARGET form without "
+ "clauses is allowed in interface block at %C");
+ goto cleanup;
+ }
+
+ m = gfc_match (" (");
+ if (m == MATCH_YES)
+ {
+ c = gfc_get_omp_clauses ();
+ gfc_current_locus = old_loc;
+ m = gfc_match_omp_to_link (" (", &c->lists[OMP_LIST_TO]);
+ if (m != MATCH_YES)
+ goto syntax;
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
+ goto cleanup;
+ }
+ }
+ else if (gfc_match_omp_clauses (&c, OMP_DECLARE_TARGET_CLAUSES) != MATCH_YES)
+ return MATCH_ERROR;
+
+ gfc_buffer_error (false);
+
+ for (list = OMP_LIST_TO; list != OMP_LIST_NUM;
+ list = (list == OMP_LIST_TO ? OMP_LIST_LINK : OMP_LIST_NUM))
+ for (n = c->lists[list]; n; n = n->next)
+ if (n->sym)
+ n->sym->mark = 0;
+ else if (n->u.common->head)
+ n->u.common->head->mark = 0;
+
+ for (list = OMP_LIST_TO; list != OMP_LIST_NUM;
+ list = (list == OMP_LIST_TO ? OMP_LIST_LINK : OMP_LIST_NUM))
+ for (n = c->lists[list]; n; n = n->next)
+ if (n->sym)
+ {
+ if (n->sym->attr.in_common)
+ gfc_error_now ("OMP DECLARE TARGET variable at %L is an "
+ "element of a COMMON block", &n->where);
+ else if (n->sym->attr.omp_declare_target
+ && n->sym->attr.omp_declare_target_link
+ && list != OMP_LIST_LINK)
+ gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
+ "mentioned in LINK clause and later in TO clause",
+ &n->where);
+ else if (n->sym->attr.omp_declare_target
+ && !n->sym->attr.omp_declare_target_link
+ && list == OMP_LIST_LINK)
+ gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
+ "mentioned in TO clause and later in LINK clause",
+ &n->where);
+ else if (n->sym->mark)
+ gfc_error_now ("Variable at %L mentioned multiple times in "
+ "clauses of the same OMP DECLARE TARGET directive",
+ &n->where);
+ else if (gfc_add_omp_declare_target (&n->sym->attr, n->sym->name,
+ &n->sym->declared_at))
+ {
+ if (list == OMP_LIST_LINK)
+ gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name,
+ &n->sym->declared_at);
+ }
+ if (c->device_type != OMP_DEVICE_TYPE_UNSET)
+ {
+ if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
+ && n->sym->attr.omp_device_type != c->device_type)
+ gfc_error_now ("List item %qs at %L set in previous OMP DECLARE "
+ "TARGET directive to a different DEVICE_TYPE",
+ n->sym->name, &n->where);
+ n->sym->attr.omp_device_type = c->device_type;
+ }
+ n->sym->mark = 1;
+ }
+ else if (n->u.common->omp_declare_target
+ && n->u.common->omp_declare_target_link
+ && list != OMP_LIST_LINK)
+ gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously "
+ "mentioned in LINK clause and later in TO clause",
+ &n->where);
+ else if (n->u.common->omp_declare_target
+ && !n->u.common->omp_declare_target_link
+ && list == OMP_LIST_LINK)
+ gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously "
+ "mentioned in TO clause and later in LINK clause",
+ &n->where);
+ else if (n->u.common->head && n->u.common->head->mark)
+ gfc_error_now ("COMMON at %L mentioned multiple times in "
+ "clauses of the same OMP DECLARE TARGET directive",
+ &n->where);
+ else
+ {
+ n->u.common->omp_declare_target = 1;
+ n->u.common->omp_declare_target_link = (list == OMP_LIST_LINK);
+ if (n->u.common->omp_device_type != OMP_DEVICE_TYPE_UNSET
+ && n->u.common->omp_device_type != c->device_type)
+ gfc_error_now ("COMMON at %L set in previous OMP DECLARE "
+ "TARGET directive to a different DEVICE_TYPE",
+ &n->where);
+ n->u.common->omp_device_type = c->device_type;
+
+ for (s = n->u.common->head; s; s = s->common_next)
+ {
+ s->mark = 1;
+ if (gfc_add_omp_declare_target (&s->attr, s->name,
+ &s->declared_at))
+ {
+ if (list == OMP_LIST_LINK)
+ gfc_add_omp_declare_target_link (&s->attr, s->name,
+ &s->declared_at);
+ }
+ if (s->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
+ && s->attr.omp_device_type != c->device_type)
+ gfc_error_now ("List item %qs at %L set in previous OMP DECLARE"
+ " TARGET directive to a different DEVICE_TYPE",
+ s->name, &n->where);
+ s->attr.omp_device_type = c->device_type;
+ }
+ }
+ if (c->device_type && !c->lists[OMP_LIST_TO] && !c->lists[OMP_LIST_LINK])
+ gfc_warning_now (0, "OMP DECLARE TARGET directive at %L with only "
+ "DEVICE_TYPE clause is ignored", &old_loc);
+
+ gfc_buffer_error (true);
+
+ if (c)
+ gfc_free_omp_clauses (c);
+ return MATCH_YES;
+
+syntax:
+ gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
+
+cleanup:
+ gfc_current_locus = old_loc;
+ if (c)
+ gfc_free_omp_clauses (c);
+ return MATCH_ERROR;
+}
+
+
+static const char *const omp_construct_selectors[] = {
+ "simd", "target", "teams", "parallel", "do", NULL };
+static const char *const omp_device_selectors[] = {
+ "kind", "isa", "arch", NULL };
+static const char *const omp_implementation_selectors[] = {
+ "vendor", "extension", "atomic_default_mem_order", "unified_address",
+ "unified_shared_memory", "dynamic_allocators", "reverse_offload", NULL };
+static const char *const omp_user_selectors[] = {
+ "condition", NULL };
+
+
+/* OpenMP 5.0:
+
+ trait-selector:
+ trait-selector-name[([trait-score:]trait-property[,trait-property[,...]])]
+
+ trait-score:
+ score(score-expression) */
+
+match
+gfc_match_omp_context_selector (gfc_omp_set_selector *oss)
+{
+ do
+ {
+ char selector[GFC_MAX_SYMBOL_LEN + 1];
+
+ if (gfc_match_name (selector) != MATCH_YES)
+ {
+ gfc_error ("expected trait selector name at %C");
+ return MATCH_ERROR;
+ }
+
+ gfc_omp_selector *os = gfc_get_omp_selector ();
+ os->trait_selector_name = XNEWVEC (char, strlen (selector) + 1);
+ strcpy (os->trait_selector_name, selector);
+ os->next = oss->trait_selectors;
+ oss->trait_selectors = os;
+
+ const char *const *selectors = NULL;
+ bool allow_score = true;
+ bool allow_user = false;
+ int property_limit = 0;
+ enum gfc_omp_trait_property_kind property_kind = CTX_PROPERTY_NONE;
+ switch (oss->trait_set_selector_name[0])
+ {
+ case 'c': /* construct */
+ selectors = omp_construct_selectors;
+ allow_score = false;
+ property_limit = 1;
+ property_kind = CTX_PROPERTY_SIMD;
+ break;
+ case 'd': /* device */
+ selectors = omp_device_selectors;
+ allow_score = false;
+ allow_user = true;
+ property_limit = 3;
+ property_kind = CTX_PROPERTY_NAME_LIST;
+ break;
+ case 'i': /* implementation */
+ selectors = omp_implementation_selectors;
+ allow_user = true;
+ property_limit = 3;
+ property_kind = CTX_PROPERTY_NAME_LIST;
+ break;
+ case 'u': /* user */
+ selectors = omp_user_selectors;
+ property_limit = 1;
+ property_kind = CTX_PROPERTY_EXPR;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ for (int i = 0; ; i++)
+ {
+ if (selectors[i] == NULL)
+ {
+ if (allow_user)
+ {
+ property_kind = CTX_PROPERTY_USER;
+ break;
+ }
+ else
+ {
+ gfc_error ("selector '%s' not allowed for context selector "
+ "set '%s' at %C",
+ selector, oss->trait_set_selector_name);
+ return MATCH_ERROR;
+ }
+ }
+ if (i == property_limit)
+ property_kind = CTX_PROPERTY_NONE;
+ if (strcmp (selectors[i], selector) == 0)
+ break;
+ }
+ if (property_kind == CTX_PROPERTY_NAME_LIST
+ && oss->trait_set_selector_name[0] == 'i'
+ && strcmp (selector, "atomic_default_mem_order") == 0)
+ property_kind = CTX_PROPERTY_ID;
+
+ if (gfc_match (" (") == MATCH_YES)
+ {
+ if (property_kind == CTX_PROPERTY_NONE)
+ {
+ gfc_error ("selector '%s' does not accept any properties at %C",
+ selector);
+ return MATCH_ERROR;
+ }
+
+ if (allow_score && gfc_match (" score") == MATCH_YES)
+ {
+ if (gfc_match (" (") != MATCH_YES)
+ {
+ gfc_error ("expected '(' at %C");
+ return MATCH_ERROR;
+ }
+ if (gfc_match_expr (&os->score) != MATCH_YES
+ || !gfc_resolve_expr (os->score)
+ || os->score->ts.type != BT_INTEGER
+ || os->score->rank != 0)
+ {
+ gfc_error ("score argument must be constant integer "
+ "expression at %C");
+ return MATCH_ERROR;
+ }
+
+ if (os->score->expr_type == EXPR_CONSTANT
+ && mpz_sgn (os->score->value.integer) < 0)
+ {
+ gfc_error ("score argument must be non-negative at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match (" )") != MATCH_YES)
+ {
+ gfc_error ("expected ')' at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match (" :") != MATCH_YES)
+ {
+ gfc_error ("expected : at %C");
+ return MATCH_ERROR;
+ }
+ }
+
+ gfc_omp_trait_property *otp = gfc_get_omp_trait_property ();
+ otp->property_kind = property_kind;
+ otp->next = os->properties;
+ os->properties = otp;
+
+ switch (property_kind)
+ {
+ case CTX_PROPERTY_USER:
+ do
+ {
+ if (gfc_match_expr (&otp->expr) != MATCH_YES)
+ {
+ gfc_error ("property must be constant integer "
+ "expression or string literal at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match (" ,") != MATCH_YES)
+ break;
+ }
+ while (1);
+ break;
+ case CTX_PROPERTY_ID:
+ {
+ char buf[GFC_MAX_SYMBOL_LEN + 1];
+ if (gfc_match_name (buf) == MATCH_YES)
+ {
+ otp->name = XNEWVEC (char, strlen (buf) + 1);
+ strcpy (otp->name, buf);
+ }
+ else
+ {
+ gfc_error ("expected identifier at %C");
+ return MATCH_ERROR;
+ }
+ }
+ break;
+ case CTX_PROPERTY_NAME_LIST:
+ do
+ {
+ char buf[GFC_MAX_SYMBOL_LEN + 1];
+ if (gfc_match_name (buf) == MATCH_YES)
+ {
+ otp->name = XNEWVEC (char, strlen (buf) + 1);
+ strcpy (otp->name, buf);
+ otp->is_name = true;
+ }
+ else if (gfc_match_literal_constant (&otp->expr, 0)
+ != MATCH_YES
+ || otp->expr->ts.type != BT_CHARACTER)
+ {
+ gfc_error ("expected identifier or string literal "
+ "at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match (" ,") == MATCH_YES)
+ {
+ otp = gfc_get_omp_trait_property ();
+ otp->property_kind = property_kind;
+ otp->next = os->properties;
+ os->properties = otp;
+ }
+ else
+ break;
+ }
+ while (1);
+ break;
+ case CTX_PROPERTY_EXPR:
+ if (gfc_match_expr (&otp->expr) != MATCH_YES)
+ {
+ gfc_error ("expected expression at %C");
+ return MATCH_ERROR;
+ }
+ if (!gfc_resolve_expr (otp->expr)
+ || (otp->expr->ts.type != BT_LOGICAL
+ && otp->expr->ts.type != BT_INTEGER)
+ || otp->expr->rank != 0)
+ {
+ gfc_error ("property must be constant integer or logical "
+ "expression at %C");
+ return MATCH_ERROR;
+ }
+ break;
+ case CTX_PROPERTY_SIMD:
+ {
+ if (gfc_match_omp_clauses (&otp->clauses,
+ OMP_DECLARE_SIMD_CLAUSES,
+ true, false, false, true)
+ != MATCH_YES)
+ {
+ gfc_error ("expected simd clause at %C");
+ return MATCH_ERROR;
+ }
+ break;
+ }
+ default:
+ gcc_unreachable ();
+ }
+
+ if (gfc_match (" )") != MATCH_YES)
+ {
+ gfc_error ("expected ')' at %C");
+ return MATCH_ERROR;
+ }
+ }
+ else if (property_kind == CTX_PROPERTY_NAME_LIST
+ || property_kind == CTX_PROPERTY_ID
+ || property_kind == CTX_PROPERTY_EXPR)
+ {
+ if (gfc_match (" (") != MATCH_YES)
+ {
+ gfc_error ("expected '(' at %C");
+ return MATCH_ERROR;
+ }
+ }
+
+ if (gfc_match (" ,") != MATCH_YES)
+ break;
+ }
+ while (1);
+
+ return MATCH_YES;
+}
+
+/* OpenMP 5.0:
+
+ trait-set-selector[,trait-set-selector[,...]]
+
+ trait-set-selector:
+ trait-set-selector-name = { trait-selector[, trait-selector[, ...]] }
+
+ trait-set-selector-name:
+ constructor
+ device
+ implementation
+ user */
+
+match
+gfc_match_omp_context_selector_specification (gfc_omp_declare_variant *odv)
+{
+ do
+ {
+ match m;
+ const char *selector_sets[] = { "construct", "device",
+ "implementation", "user" };
+ const int selector_set_count
+ = sizeof (selector_sets) / sizeof (*selector_sets);
+ int i;
+ char buf[GFC_MAX_SYMBOL_LEN + 1];
+
+ m = gfc_match_name (buf);
+ if (m == MATCH_YES)
+ for (i = 0; i < selector_set_count; i++)
+ if (strcmp (buf, selector_sets[i]) == 0)
+ break;
+
+ if (m != MATCH_YES || i == selector_set_count)
+ {
+ gfc_error ("expected 'construct', 'device', 'implementation' or "
+ "'user' at %C");
+ return MATCH_ERROR;
+ }
+
+ m = gfc_match (" =");
+ if (m != MATCH_YES)
+ {
+ gfc_error ("expected '=' at %C");
+ return MATCH_ERROR;
+ }
+
+ m = gfc_match (" {");
+ if (m != MATCH_YES)
+ {
+ gfc_error ("expected '{' at %C");
+ return MATCH_ERROR;
+ }
+
+ gfc_omp_set_selector *oss = gfc_get_omp_set_selector ();
+ oss->next = odv->set_selectors;
+ oss->trait_set_selector_name = selector_sets[i];
+ odv->set_selectors = oss;
+
+ if (gfc_match_omp_context_selector (oss) != MATCH_YES)
+ return MATCH_ERROR;
+
+ m = gfc_match (" }");
+ if (m != MATCH_YES)
+ {
+ gfc_error ("expected '}' at %C");
+ return MATCH_ERROR;
+ }
+
+ m = gfc_match (" ,");
+ if (m != MATCH_YES)
+ break;
+ }
+ while (1);
+
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_declare_variant (void)
+{
+ bool first_p = true;
+ char buf[GFC_MAX_SYMBOL_LEN + 1];
+
+ if (gfc_match (" (") != MATCH_YES)
+ {
+ gfc_error ("expected '(' at %C");
+ return MATCH_ERROR;
+ }
+
+ gfc_symtree *base_proc_st, *variant_proc_st;
+ if (gfc_match_name (buf) != MATCH_YES)
+ {
+ gfc_error ("expected name at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_get_ha_sym_tree (buf, &base_proc_st))
+ return MATCH_ERROR;
+
+ if (gfc_match (" :") == MATCH_YES)
+ {
+ if (gfc_match_name (buf) != MATCH_YES)
+ {
+ gfc_error ("expected variant name at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_get_ha_sym_tree (buf, &variant_proc_st))
+ return MATCH_ERROR;
+ }
+ else
+ {
+ /* Base procedure not specified. */
+ variant_proc_st = base_proc_st;
+ base_proc_st = NULL;
+ }
+
+ gfc_omp_declare_variant *odv;
+ odv = gfc_get_omp_declare_variant ();
+ odv->where = gfc_current_locus;
+ odv->variant_proc_symtree = variant_proc_st;
+ odv->base_proc_symtree = base_proc_st;
+ odv->next = NULL;
+ odv->error_p = false;
+
+ /* Add the new declare variant to the end of the list. */
+ gfc_omp_declare_variant **prev_next = &gfc_current_ns->omp_declare_variant;
+ while (*prev_next)
+ prev_next = &((*prev_next)->next);
+ *prev_next = odv;
+
+ if (gfc_match (" )") != MATCH_YES)
+ {
+ gfc_error ("expected ')' at %C");
+ return MATCH_ERROR;
+ }
+
+ for (;;)
+ {
+ if (gfc_match (" match") != MATCH_YES)
+ {
+ if (first_p)
+ {
+ gfc_error ("expected 'match' at %C");
+ return MATCH_ERROR;
+ }
+ else
+ break;
+ }
+
+ if (gfc_match (" (") != MATCH_YES)
+ {
+ gfc_error ("expected '(' at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match_omp_context_selector_specification (odv) != MATCH_YES)
+ return MATCH_ERROR;
+
+ if (gfc_match (" )") != MATCH_YES)
+ {
+ gfc_error ("expected ')' at %C");
+ return MATCH_ERROR;
+ }
+
+ first_p = false;
+ }
+
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_threadprivate (void)
+{
+ locus old_loc;
+ char n[GFC_MAX_SYMBOL_LEN+1];
+ gfc_symbol *sym;
+ match m;
+ gfc_symtree *st;
+
+ old_loc = gfc_current_locus;
+
+ m = gfc_match (" (");
+ if (m != MATCH_YES)
+ return m;
+
+ for (;;)
+ {
+ m = gfc_match_symbol (&sym, 0);
+ switch (m)
+ {
+ case MATCH_YES:
+ if (sym->attr.in_common)
+ gfc_error_now ("Threadprivate variable at %C is an element of "
+ "a COMMON block");
+ else if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
+ goto cleanup;
+ goto next_item;
+ case MATCH_NO:
+ break;
+ case MATCH_ERROR:
+ goto cleanup;
+ }
+
+ m = gfc_match (" / %n /", n);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_NO || n[0] == '\0')
+ goto syntax;
+
+ st = gfc_find_symtree (gfc_current_ns->common_root, n);
+ if (st == NULL)
+ {
+ gfc_error ("COMMON block /%s/ not found at %C", n);
+ goto cleanup;
+ }
+ st->n.common->threadprivate = 1;
+ for (sym = st->n.common->head; sym; sym = sym->common_next)
+ if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
+ goto cleanup;
+
+ next_item:
+ if (gfc_match_char (')') == MATCH_YES)
+ break;
+ if (gfc_match_char (',') != MATCH_YES)
+ goto syntax;
+ }
+
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C");
+ goto cleanup;
+ }
+
+ return MATCH_YES;
+
+syntax:
+ gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
+
+cleanup:
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+}
+
+
+match
+gfc_match_omp_parallel (void)
+{
+ return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES);
+}
+
+
+match
+gfc_match_omp_parallel_do (void)
+{
+ return match_omp (EXEC_OMP_PARALLEL_DO,
+ OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES);
+}
+
+
+match
+gfc_match_omp_parallel_do_simd (void)
+{
+ return match_omp (EXEC_OMP_PARALLEL_DO_SIMD,
+ OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES);
+}
+
+
+match
+gfc_match_omp_parallel_masked (void)
+{
+ return match_omp (EXEC_OMP_PARALLEL_MASKED,
+ OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES);
+}
+
+match
+gfc_match_omp_parallel_masked_taskloop (void)
+{
+ return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP,
+ (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
+ | OMP_TASKLOOP_CLAUSES)
+ & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
+}
+
+match
+gfc_match_omp_parallel_masked_taskloop_simd (void)
+{
+ return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD,
+ (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
+ | OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES)
+ & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
+}
+
+match
+gfc_match_omp_parallel_master (void)
+{
+ return match_omp (EXEC_OMP_PARALLEL_MASTER, OMP_PARALLEL_CLAUSES);
+}
+
+match
+gfc_match_omp_parallel_master_taskloop (void)
+{
+ return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP,
+ (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES)
+ & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
+}
+
+match
+gfc_match_omp_parallel_master_taskloop_simd (void)
+{
+ return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD,
+ (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES
+ | OMP_SIMD_CLAUSES)
+ & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
+}
+
+match
+gfc_match_omp_parallel_sections (void)
+{
+ return match_omp (EXEC_OMP_PARALLEL_SECTIONS,
+ OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES);
+}
+
+
+match
+gfc_match_omp_parallel_workshare (void)
+{
+ return match_omp (EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES);
+}
+
+void
+gfc_check_omp_requires (gfc_namespace *ns, int ref_omp_requires)
+{
+ if (ns->omp_target_seen
+ && (ns->omp_requires & OMP_REQ_TARGET_MASK)
+ != (ref_omp_requires & OMP_REQ_TARGET_MASK))
+ {
+ gcc_assert (ns->proc_name);
+ if ((ref_omp_requires & OMP_REQ_REVERSE_OFFLOAD)
+ && !(ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD))
+ gfc_error ("Program unit at %L has OpenMP device constructs/routines "
+ "but does not set !$OMP REQUIRES REVERSE_OFFSET but other "
+ "program units do", &ns->proc_name->declared_at);
+ if ((ref_omp_requires & OMP_REQ_UNIFIED_ADDRESS)
+ && !(ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS))
+ gfc_error ("Program unit at %L has OpenMP device constructs/routines "
+ "but does not set !$OMP REQUIRES UNIFIED_ADDRESS but other "
+ "program units do", &ns->proc_name->declared_at);
+ if ((ref_omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)
+ && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
+ gfc_error ("Program unit at %L has OpenMP device constructs/routines "
+ "but does not set !$OMP REQUIRES UNIFIED_SHARED_MEMORY but "
+ "other program units do", &ns->proc_name->declared_at);
+ }
+}
+
+bool
+gfc_omp_requires_add_clause (gfc_omp_requires_kind clause,
+ const char *clause_name, locus *loc,
+ const char *module_name)
+{
+ gfc_namespace *prog_unit = gfc_current_ns;
+ while (prog_unit->parent)
+ {
+ if (gfc_state_stack->previous
+ && gfc_state_stack->previous->state == COMP_INTERFACE)
+ break;
+ prog_unit = prog_unit->parent;
+ }
+
+ /* Requires added after use. */
+ if (prog_unit->omp_target_seen
+ && (clause & OMP_REQ_TARGET_MASK)
+ && !(prog_unit->omp_requires & clause))
+ {
+ if (module_name)
+ gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use "
+ "at %L comes after using a device construct/routine",
+ clause_name, module_name, loc);
+ else
+ gfc_error ("!$OMP REQUIRES clause %qs specified at %L comes after "
+ "using a device construct/routine", clause_name, loc);
+ return false;
+ }
+
+ /* Overriding atomic_default_mem_order clause value. */
+ if ((clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
+ && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
+ && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
+ != (int) clause)
+ {
+ const char *other;
+ if (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST)
+ other = "seq_cst";
+ else if (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL)
+ other = "acq_rel";
+ else if (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_RELAXED)
+ other = "relaxed";
+ else
+ gcc_unreachable ();
+
+ if (module_name)
+ gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
+ "specified via module %qs use at %L overrides a previous "
+ "%<atomic_default_mem_order(%s)%> (which might be through "
+ "using a module)", clause_name, module_name, loc, other);
+ else
+ gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
+ "specified at %L overrides a previous "
+ "%<atomic_default_mem_order(%s)%> (which might be through "
+ "using a module)", clause_name, loc, other);
+ return false;
+ }
+
+ /* Requires via module not at program-unit level and not repeating clause. */
+ if (prog_unit != gfc_current_ns && !(prog_unit->omp_requires & clause))
+ {
+ if (clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
+ gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
+ "specified via module %qs use at %L but same clause is "
+ "not specified for the program unit", clause_name,
+ module_name, loc);
+ else
+ gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use at "
+ "%L but same clause is not specified for the program unit",
+ clause_name, module_name, loc);
+ return false;
+ }
+
+ if (!gfc_state_stack->previous
+ || gfc_state_stack->previous->state != COMP_INTERFACE)
+ prog_unit->omp_requires |= clause;
+ return true;
+}
+
+match
+gfc_match_omp_requires (void)
+{
+ static const char *clauses[] = {"reverse_offload",
+ "unified_address",
+ "unified_shared_memory",
+ "dynamic_allocators",
+ "atomic_default"};
+ const char *clause = NULL;
+ int requires_clauses = 0;
+ bool first = true;
+ locus old_loc;
+
+ if (gfc_current_ns->parent
+ && (!gfc_state_stack->previous
+ || gfc_state_stack->previous->state != COMP_INTERFACE))
+ {
+ gfc_error ("!$OMP REQUIRES at %C must appear in the specification part "
+ "of a program unit");
+ return MATCH_ERROR;
+ }
+
+ while (true)
+ {
+ old_loc = gfc_current_locus;
+ gfc_omp_requires_kind requires_clause;
+ if ((first || gfc_match_char (',') != MATCH_YES)
+ && (first && gfc_match_space () != MATCH_YES))
+ goto error;
+ first = false;
+ gfc_gobble_whitespace ();
+ old_loc = gfc_current_locus;
+
+ if (gfc_match_omp_eos () != MATCH_NO)
+ break;
+ if (gfc_match (clauses[0]) == MATCH_YES)
+ {
+ clause = clauses[0];
+ requires_clause = OMP_REQ_REVERSE_OFFLOAD;
+ if (requires_clauses & OMP_REQ_REVERSE_OFFLOAD)
+ goto duplicate_clause;
+ }
+ else if (gfc_match (clauses[1]) == MATCH_YES)
+ {
+ clause = clauses[1];
+ requires_clause = OMP_REQ_UNIFIED_ADDRESS;
+ if (requires_clauses & OMP_REQ_UNIFIED_ADDRESS)
+ goto duplicate_clause;
+ }
+ else if (gfc_match (clauses[2]) == MATCH_YES)
+ {
+ clause = clauses[2];
+ requires_clause = OMP_REQ_UNIFIED_SHARED_MEMORY;
+ if (requires_clauses & OMP_REQ_UNIFIED_SHARED_MEMORY)
+ goto duplicate_clause;
+ }
+ else if (gfc_match (clauses[3]) == MATCH_YES)
+ {
+ clause = clauses[3];
+ requires_clause = OMP_REQ_DYNAMIC_ALLOCATORS;
+ if (requires_clauses & OMP_REQ_DYNAMIC_ALLOCATORS)
+ goto duplicate_clause;
+ }
+ else if (gfc_match ("atomic_default_mem_order (") == MATCH_YES)
+ {
+ clause = clauses[4];
+ if (requires_clauses & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
+ goto duplicate_clause;
+ if (gfc_match (" seq_cst )") == MATCH_YES)
+ {
+ clause = "seq_cst";
+ requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST;
+ }
+ else if (gfc_match (" acq_rel )") == MATCH_YES)
+ {
+ clause = "acq_rel";
+ requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL;
+ }
+ else if (gfc_match (" relaxed )") == MATCH_YES)
+ {
+ clause = "relaxed";
+ requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELAXED;
+ }
+ else
+ {
+ gfc_error ("Expected SEQ_CST, ACQ_REL or RELAXED for "
+ "ATOMIC_DEFAULT_MEM_ORDER clause at %C");
+ goto error;
+ }
+ }
+ else
+ goto error;
+
+ if (requires_clause & ~(OMP_REQ_ATOMIC_MEM_ORDER_MASK
+ | OMP_REQ_DYNAMIC_ALLOCATORS))
+ gfc_error_now ("Sorry, %qs clause at %L on REQUIRES directive is not "
+ "yet supported", clause, &old_loc);
+ if (!gfc_omp_requires_add_clause (requires_clause, clause, &old_loc, NULL))
+ goto error;
+ requires_clauses |= requires_clause;
+ }
+
+ if (requires_clauses == 0)
+ {
+ if (!gfc_error_flag_test ())
+ gfc_error ("Clause expected at %C");
+ goto error;
+ }
+ return MATCH_YES;
+
+duplicate_clause:
+ gfc_error ("%qs clause at %L specified more than once", clause, &old_loc);
+error:
+ if (!gfc_error_flag_test ())
+ gfc_error ("Expected UNIFIED_ADDRESS, UNIFIED_SHARED_MEMORY, "
+ "DYNAMIC_ALLOCATORS, REVERSE_OFFLOAD, or "
+ "ATOMIC_DEFAULT_MEM_ORDER clause at %L", &old_loc);
+ return MATCH_ERROR;
+}
+
+
+match
+gfc_match_omp_scan (void)
+{
+ bool incl;
+ gfc_omp_clauses *c = gfc_get_omp_clauses ();
+ gfc_gobble_whitespace ();
+ if ((incl = (gfc_match ("inclusive") == MATCH_YES))
+ || gfc_match ("exclusive") == MATCH_YES)
+ {
+ if (gfc_match_omp_variable_list (" (", &c->lists[incl ? OMP_LIST_SCAN_IN
+ : OMP_LIST_SCAN_EX],
+ false) != MATCH_YES)
+ {
+ gfc_free_omp_clauses (c);
+ return MATCH_ERROR;
+ }
+ }
+ else
+ {
+ gfc_error ("Expected INCLUSIVE or EXCLUSIVE clause at %C");
+ gfc_free_omp_clauses (c);
+ return MATCH_ERROR;
+ }
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after !$OMP SCAN at %C");
+ gfc_free_omp_clauses (c);
+ return MATCH_ERROR;
+ }
+
+ new_st.op = EXEC_OMP_SCAN;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_scope (void)
+{
+ return match_omp (EXEC_OMP_SCOPE, OMP_SCOPE_CLAUSES);
+}
+
+
+match
+gfc_match_omp_sections (void)
+{
+ return match_omp (EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES);
+}
+
+
+match
+gfc_match_omp_simd (void)
+{
+ return match_omp (EXEC_OMP_SIMD, OMP_SIMD_CLAUSES);
+}
+
+
+match
+gfc_match_omp_single (void)
+{
+ return match_omp (EXEC_OMP_SINGLE, OMP_SINGLE_CLAUSES);
+}
+
+
+match
+gfc_match_omp_target (void)
+{
+ return match_omp (EXEC_OMP_TARGET, OMP_TARGET_CLAUSES);
+}
+
+
+match
+gfc_match_omp_target_data (void)
+{
+ return match_omp (EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES);
+}
+
+
+match
+gfc_match_omp_target_enter_data (void)
+{
+ return match_omp (EXEC_OMP_TARGET_ENTER_DATA, OMP_TARGET_ENTER_DATA_CLAUSES);
+}
+
+
+match
+gfc_match_omp_target_exit_data (void)
+{
+ return match_omp (EXEC_OMP_TARGET_EXIT_DATA, OMP_TARGET_EXIT_DATA_CLAUSES);
+}
+
+
+match
+gfc_match_omp_target_parallel (void)
+{
+ return match_omp (EXEC_OMP_TARGET_PARALLEL,
+ (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES)
+ & ~(omp_mask (OMP_CLAUSE_COPYIN)));
+}
+
+
+match
+gfc_match_omp_target_parallel_do (void)
+{
+ return match_omp (EXEC_OMP_TARGET_PARALLEL_DO,
+ (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
+ | OMP_DO_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
+}
+
+
+match
+gfc_match_omp_target_parallel_do_simd (void)
+{
+ return match_omp (EXEC_OMP_TARGET_PARALLEL_DO_SIMD,
+ (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
+ | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
+}
+
+
+match
+gfc_match_omp_target_simd (void)
+{
+ return match_omp (EXEC_OMP_TARGET_SIMD,
+ OMP_TARGET_CLAUSES | OMP_SIMD_CLAUSES);
+}
+
+
+match
+gfc_match_omp_target_teams (void)
+{
+ return match_omp (EXEC_OMP_TARGET_TEAMS,
+ OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES);
+}
+
+
+match
+gfc_match_omp_target_teams_distribute (void)
+{
+ return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE,
+ OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
+ | OMP_DISTRIBUTE_CLAUSES);
+}
+
+
+match
+gfc_match_omp_target_teams_distribute_parallel_do (void)
+{
+ return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO,
+ (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
+ | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
+ | OMP_DO_CLAUSES)
+ & ~(omp_mask (OMP_CLAUSE_ORDERED))
+ & ~(omp_mask (OMP_CLAUSE_LINEAR)));
+}
+
+
+match
+gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
+{
+ return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
+ (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
+ | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
+ | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
+ & ~(omp_mask (OMP_CLAUSE_ORDERED)));
+}
+
+
+match
+gfc_match_omp_target_teams_distribute_simd (void)
+{
+ return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD,
+ OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
+ | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
+}
+
+
+match
+gfc_match_omp_target_update (void)
+{
+ return match_omp (EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES);
+}
+
+
+match
+gfc_match_omp_task (void)
+{
+ return match_omp (EXEC_OMP_TASK, OMP_TASK_CLAUSES);
+}
+
+
+match
+gfc_match_omp_taskloop (void)
+{
+ return match_omp (EXEC_OMP_TASKLOOP, OMP_TASKLOOP_CLAUSES);
+}
+
+
+match
+gfc_match_omp_taskloop_simd (void)
+{
+ return match_omp (EXEC_OMP_TASKLOOP_SIMD,
+ OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
+}
+
+
+match
+gfc_match_omp_taskwait (void)
+{
+ if (gfc_match_omp_eos () == MATCH_YES)
+ {
+ new_st.op = EXEC_OMP_TASKWAIT;
+ new_st.ext.omp_clauses = NULL;
+ return MATCH_YES;
+ }
+ return match_omp (EXEC_OMP_TASKWAIT, omp_mask (OMP_CLAUSE_DEPEND));
+}
+
+
+match
+gfc_match_omp_taskyield (void)
+{
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after TASKYIELD clause at %C");
+ return MATCH_ERROR;
+ }
+ new_st.op = EXEC_OMP_TASKYIELD;
+ new_st.ext.omp_clauses = NULL;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_teams (void)
+{
+ return match_omp (EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES);
+}
+
+
+match
+gfc_match_omp_teams_distribute (void)
+{
+ return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE,
+ OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES);
+}
+
+
+match
+gfc_match_omp_teams_distribute_parallel_do (void)
+{
+ return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO,
+ (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
+ | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
+ & ~(omp_mask (OMP_CLAUSE_ORDERED))
+ & ~(omp_mask (OMP_CLAUSE_LINEAR)));
+}
+
+
+match
+gfc_match_omp_teams_distribute_parallel_do_simd (void)
+{
+ return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
+ (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
+ | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
+ | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_ORDERED)));
+}
+
+
+match
+gfc_match_omp_teams_distribute_simd (void)
+{
+ return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD,
+ OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
+ | OMP_SIMD_CLAUSES);
+}
+
+
+match
+gfc_match_omp_workshare (void)
+{
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after $OMP WORKSHARE statement at %C");
+ return MATCH_ERROR;
+ }
+ new_st.op = EXEC_OMP_WORKSHARE;
+ new_st.ext.omp_clauses = gfc_get_omp_clauses ();
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_masked (void)
+{
+ return match_omp (EXEC_OMP_MASKED, OMP_MASKED_CLAUSES);
+}
+
+match
+gfc_match_omp_masked_taskloop (void)
+{
+ return match_omp (EXEC_OMP_MASKED_TASKLOOP,
+ OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES);
+}
+
+match
+gfc_match_omp_masked_taskloop_simd (void)
+{
+ return match_omp (EXEC_OMP_MASKED_TASKLOOP_SIMD,
+ (OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES
+ | OMP_SIMD_CLAUSES));
+}
+
+match
+gfc_match_omp_master (void)
+{
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
+ return MATCH_ERROR;
+ }
+ new_st.op = EXEC_OMP_MASTER;
+ new_st.ext.omp_clauses = NULL;
+ return MATCH_YES;
+}
+
+match
+gfc_match_omp_master_taskloop (void)
+{
+ return match_omp (EXEC_OMP_MASTER_TASKLOOP, OMP_TASKLOOP_CLAUSES);
+}
+
+match
+gfc_match_omp_master_taskloop_simd (void)
+{
+ return match_omp (EXEC_OMP_MASTER_TASKLOOP_SIMD,
+ OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
+}
+
+match
+gfc_match_omp_ordered (void)
+{
+ return match_omp (EXEC_OMP_ORDERED, OMP_ORDERED_CLAUSES);
+}
+
+match
+gfc_match_omp_nothing (void)
+{
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after $OMP NOTHING statement at %C");
+ return MATCH_ERROR;
+ }
+ /* Will use ST_NONE; therefore, no EXEC_OMP_ is needed. */
+ return MATCH_YES;
+}
+
+match
+gfc_match_omp_ordered_depend (void)
+{
+ return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DEPEND));
+}
+
+
+/* omp atomic [clause-list]
+ - atomic-clause: read | write | update
+ - capture
+ - memory-order-clause: seq_cst | acq_rel | release | acquire | relaxed
+ - hint(hint-expr)
+ - OpenMP 5.1: compare | fail (seq_cst | acquire | relaxed ) | weak
+*/
+
+match
+gfc_match_omp_atomic (void)
+{
+ gfc_omp_clauses *c;
+ locus loc = gfc_current_locus;
+
+ if (gfc_match_omp_clauses (&c, OMP_ATOMIC_CLAUSES, true, true) != MATCH_YES)
+ return MATCH_ERROR;
+
+ if (c->atomic_op == GFC_OMP_ATOMIC_UNSET)
+ c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
+
+ if (c->capture && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
+ gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
+ "READ or WRITE", &loc, "CAPTURE");
+ if (c->compare && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
+ gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
+ "READ or WRITE", &loc, "COMPARE");
+ if (c->fail != OMP_MEMORDER_UNSET && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
+ gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
+ "READ or WRITE", &loc, "FAIL");
+ if (c->weak && !c->compare)
+ {
+ gfc_error ("!$OMP ATOMIC at %L with %s clause requires %s clause", &loc,
+ "WEAK", "COMPARE");
+ c->weak = false;
+ }
+
+ if (c->memorder == OMP_MEMORDER_UNSET)
+ {
+ gfc_namespace *prog_unit = gfc_current_ns;
+ while (prog_unit->parent)
+ prog_unit = prog_unit->parent;
+ switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
+ {
+ case 0:
+ case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
+ c->memorder = OMP_MEMORDER_RELAXED;
+ break;
+ case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
+ c->memorder = OMP_MEMORDER_SEQ_CST;
+ break;
+ case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
+ if (c->capture)
+ c->memorder = OMP_MEMORDER_ACQ_REL;
+ else if (c->atomic_op == GFC_OMP_ATOMIC_READ)
+ c->memorder = OMP_MEMORDER_ACQUIRE;
+ else
+ c->memorder = OMP_MEMORDER_RELEASE;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ }
+ else
+ switch (c->atomic_op)
+ {
+ case GFC_OMP_ATOMIC_READ:
+ if (c->memorder == OMP_MEMORDER_RELEASE)
+ {
+ gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
+ "RELEASE clause", &loc);
+ c->memorder = OMP_MEMORDER_SEQ_CST;
+ }
+ else if (c->memorder == OMP_MEMORDER_ACQ_REL)
+ c->memorder = OMP_MEMORDER_ACQUIRE;
+ break;
+ case GFC_OMP_ATOMIC_WRITE:
+ if (c->memorder == OMP_MEMORDER_ACQUIRE)
+ {
+ gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
+ "ACQUIRE clause", &loc);
+ c->memorder = OMP_MEMORDER_SEQ_CST;
+ }
+ else if (c->memorder == OMP_MEMORDER_ACQ_REL)
+ c->memorder = OMP_MEMORDER_RELEASE;
+ break;
+ default:
+ break;
+ }
+ gfc_error_check ();
+ new_st.ext.omp_clauses = c;
+ new_st.op = EXEC_OMP_ATOMIC;
+ return MATCH_YES;
+}
+
+
+/* acc atomic [ read | write | update | capture] */
+
+match
+gfc_match_oacc_atomic (void)
+{
+ gfc_omp_clauses *c = gfc_get_omp_clauses ();
+ c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
+ c->memorder = OMP_MEMORDER_RELAXED;
+ gfc_gobble_whitespace ();
+ if (gfc_match ("update") == MATCH_YES)
+ ;
+ else if (gfc_match ("read") == MATCH_YES)
+ c->atomic_op = GFC_OMP_ATOMIC_READ;
+ else if (gfc_match ("write") == MATCH_YES)
+ c->atomic_op = GFC_OMP_ATOMIC_WRITE;
+ else if (gfc_match ("capture") == MATCH_YES)
+ c->capture = true;
+ gfc_gobble_whitespace ();
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after !$ACC ATOMIC statement at %C");
+ gfc_free_omp_clauses (c);
+ return MATCH_ERROR;
+ }
+ new_st.ext.omp_clauses = c;
+ new_st.op = EXEC_OACC_ATOMIC;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_barrier (void)
+{
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
+ return MATCH_ERROR;
+ }
+ new_st.op = EXEC_OMP_BARRIER;
+ new_st.ext.omp_clauses = NULL;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_taskgroup (void)
+{
+ return match_omp (EXEC_OMP_TASKGROUP, OMP_TASKGROUP_CLAUSES);
+}
+
+
+static enum gfc_omp_cancel_kind
+gfc_match_omp_cancel_kind (void)
+{
+ if (gfc_match_space () != MATCH_YES)
+ return OMP_CANCEL_UNKNOWN;
+ if (gfc_match ("parallel") == MATCH_YES)
+ return OMP_CANCEL_PARALLEL;
+ if (gfc_match ("sections") == MATCH_YES)
+ return OMP_CANCEL_SECTIONS;
+ if (gfc_match ("do") == MATCH_YES)
+ return OMP_CANCEL_DO;
+ if (gfc_match ("taskgroup") == MATCH_YES)
+ return OMP_CANCEL_TASKGROUP;
+ return OMP_CANCEL_UNKNOWN;
+}
+
+
+match
+gfc_match_omp_cancel (void)
+{
+ gfc_omp_clauses *c;
+ enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
+ if (kind == OMP_CANCEL_UNKNOWN)
+ return MATCH_ERROR;
+ if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_IF), false) != MATCH_YES)
+ return MATCH_ERROR;
+ c->cancel = kind;
+ new_st.op = EXEC_OMP_CANCEL;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_cancellation_point (void)
+{
+ gfc_omp_clauses *c;
+ enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
+ if (kind == OMP_CANCEL_UNKNOWN)
+ {
+ gfc_error ("Expected construct-type PARALLEL, SECTIONS, DO or TASKGROUP "
+ "in $OMP CANCELLATION POINT statement at %C");
+ return MATCH_ERROR;
+ }
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
+ "at %C");
+ return MATCH_ERROR;
+ }
+ c = gfc_get_omp_clauses ();
+ c->cancel = kind;
+ new_st.op = EXEC_OMP_CANCELLATION_POINT;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_end_nowait (void)
+{
+ bool nowait = false;
+ if (gfc_match ("% nowait") == MATCH_YES)
+ nowait = true;
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ if (nowait)
+ gfc_error ("Unexpected junk after NOWAIT clause at %C");
+ else
+ gfc_error ("Unexpected junk at %C");
+ return MATCH_ERROR;
+ }
+ new_st.op = EXEC_OMP_END_NOWAIT;
+ new_st.ext.omp_bool = nowait;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_end_single (void)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match ("% nowait") == MATCH_YES)
+ {
+ new_st.op = EXEC_OMP_END_NOWAIT;
+ new_st.ext.omp_bool = true;
+ return MATCH_YES;
+ }
+ if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_COPYPRIVATE))
+ != MATCH_YES)
+ return MATCH_ERROR;
+ new_st.op = EXEC_OMP_END_SINGLE;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+static bool
+oacc_is_loop (gfc_code *code)
+{
+ return code->op == EXEC_OACC_PARALLEL_LOOP
+ || code->op == EXEC_OACC_KERNELS_LOOP
+ || code->op == EXEC_OACC_SERIAL_LOOP
+ || code->op == EXEC_OACC_LOOP;
+}
+
+static void
+resolve_scalar_int_expr (gfc_expr *expr, const char *clause)
+{
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_INTEGER
+ || expr->rank != 0)
+ gfc_error ("%s clause at %L requires a scalar INTEGER expression",
+ clause, &expr->where);
+}
+
+static void
+resolve_positive_int_expr (gfc_expr *expr, const char *clause)
+{
+ resolve_scalar_int_expr (expr, clause);
+ if (expr->expr_type == EXPR_CONSTANT
+ && expr->ts.type == BT_INTEGER
+ && mpz_sgn (expr->value.integer) <= 0)
+ gfc_warning (0, "INTEGER expression of %s clause at %L must be positive",
+ clause, &expr->where);
+}
+
+static void
+resolve_nonnegative_int_expr (gfc_expr *expr, const char *clause)
+{
+ resolve_scalar_int_expr (expr, clause);
+ if (expr->expr_type == EXPR_CONSTANT
+ && expr->ts.type == BT_INTEGER
+ && mpz_sgn (expr->value.integer) < 0)
+ gfc_warning (0, "INTEGER expression of %s clause at %L must be "
+ "non-negative", clause, &expr->where);
+}
+
+/* Emits error when symbol is pointer, cray pointer or cray pointee
+ of derived of polymorphic type. */
+
+static void
+check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name)
+{
+ if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer)
+ gfc_error ("Cray pointer object %qs of derived type in %s clause at %L",
+ sym->name, name, &loc);
+ if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee)
+ gfc_error ("Cray pointee object %qs of derived type in %s clause at %L",
+ sym->name, name, &loc);
+
+ if ((sym->ts.type == BT_ASSUMED && sym->attr.pointer)
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && CLASS_DATA (sym)->attr.pointer))
+ gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L",
+ sym->name, name, &loc);
+ if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointer)
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && CLASS_DATA (sym)->attr.cray_pointer))
+ gfc_error ("Cray pointer object %qs of polymorphic type in %s clause at %L",
+ sym->name, name, &loc);
+ if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointee)
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && CLASS_DATA (sym)->attr.cray_pointee))
+ gfc_error ("Cray pointee object %qs of polymorphic type in %s clause at %L",
+ sym->name, name, &loc);
+}
+
+/* Emits error when symbol represents assumed size/rank array. */
+
+static void
+check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name)
+{
+ if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
+ gfc_error ("Assumed size array %qs in %s clause at %L",
+ sym->name, name, &loc);
+ if (sym->as && sym->as->type == AS_ASSUMED_RANK)
+ gfc_error ("Assumed rank array %qs in %s clause at %L",
+ sym->name, name, &loc);
+}
+
+static void
+resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name)
+{
+ check_array_not_assumed (sym, loc, name);
+}
+
+static void
+resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name)
+{
+ if (sym->attr.pointer
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && CLASS_DATA (sym)->attr.class_pointer))
+ gfc_error ("POINTER object %qs in %s clause at %L",
+ sym->name, name, &loc);
+ if (sym->attr.cray_pointer
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && CLASS_DATA (sym)->attr.cray_pointer))
+ gfc_error ("Cray pointer object %qs in %s clause at %L",
+ sym->name, name, &loc);
+ if (sym->attr.cray_pointee
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && CLASS_DATA (sym)->attr.cray_pointee))
+ gfc_error ("Cray pointee object %qs in %s clause at %L",
+ sym->name, name, &loc);
+ if (sym->attr.allocatable
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && CLASS_DATA (sym)->attr.allocatable))
+ gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
+ sym->name, name, &loc);
+ if (sym->attr.value)
+ gfc_error ("VALUE object %qs in %s clause at %L",
+ sym->name, name, &loc);
+ check_array_not_assumed (sym, loc, name);
+}
+
+
+struct resolve_omp_udr_callback_data
+{
+ gfc_symbol *sym1, *sym2;
+};
+
+
+static int
+resolve_omp_udr_callback (gfc_expr **e, int *, void *data)
+{
+ struct resolve_omp_udr_callback_data *rcd
+ = (struct resolve_omp_udr_callback_data *) data;
+ if ((*e)->expr_type == EXPR_VARIABLE
+ && ((*e)->symtree->n.sym == rcd->sym1
+ || (*e)->symtree->n.sym == rcd->sym2))
+ {
+ gfc_ref *ref = gfc_get_ref ();
+ ref->type = REF_ARRAY;
+ ref->u.ar.where = (*e)->where;
+ ref->u.ar.as = (*e)->symtree->n.sym->as;
+ ref->u.ar.type = AR_FULL;
+ ref->u.ar.dimen = 0;
+ ref->next = (*e)->ref;
+ (*e)->ref = ref;
+ }
+ return 0;
+}
+
+
+static int
+resolve_omp_udr_callback2 (gfc_expr **e, int *, void *)
+{
+ if ((*e)->expr_type == EXPR_FUNCTION
+ && (*e)->value.function.isym == NULL)
+ {
+ gfc_symbol *sym = (*e)->symtree->n.sym;
+ if (!sym->attr.intrinsic
+ && sym->attr.if_source == IFSRC_UNKNOWN)
+ gfc_error ("Implicitly declared function %s used in "
+ "!$OMP DECLARE REDUCTION at %L", sym->name, &(*e)->where);
+ }
+ return 0;
+}
+
+
+static gfc_code *
+resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
+ gfc_symbol *sym1, gfc_symbol *sym2)
+{
+ gfc_code *copy;
+ gfc_symbol sym1_copy, sym2_copy;
+
+ if (ns->code->op == EXEC_ASSIGN)
+ {
+ copy = gfc_get_code (EXEC_ASSIGN);
+ copy->expr1 = gfc_copy_expr (ns->code->expr1);
+ copy->expr2 = gfc_copy_expr (ns->code->expr2);
+ }
+ else
+ {
+ copy = gfc_get_code (EXEC_CALL);
+ copy->symtree = ns->code->symtree;
+ copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual);
+ }
+ copy->loc = ns->code->loc;
+ sym1_copy = *sym1;
+ sym2_copy = *sym2;
+ *sym1 = *n->sym;
+ *sym2 = *n->sym;
+ sym1->name = sym1_copy.name;
+ sym2->name = sym2_copy.name;
+ ns->proc_name = ns->parent->proc_name;
+ if (n->sym->attr.dimension)
+ {
+ struct resolve_omp_udr_callback_data rcd;
+ rcd.sym1 = sym1;
+ rcd.sym2 = sym2;
+ gfc_code_walker (&copy, gfc_dummy_code_callback,
+ resolve_omp_udr_callback, &rcd);
+ }
+ gfc_resolve_code (copy, gfc_current_ns);
+ if (copy->op == EXEC_CALL && copy->resolved_isym == NULL)
+ {
+ gfc_symbol *sym = copy->resolved_sym;
+ if (sym
+ && !sym->attr.intrinsic
+ && sym->attr.if_source == IFSRC_UNKNOWN)
+ gfc_error ("Implicitly declared subroutine %s used in "
+ "!$OMP DECLARE REDUCTION at %L", sym->name,
+ &copy->loc);
+ }
+ gfc_code_walker (&copy, gfc_dummy_code_callback,
+ resolve_omp_udr_callback2, NULL);
+ *sym1 = sym1_copy;
+ *sym2 = sym2_copy;
+ return copy;
+}
+
+/* OpenMP directive resolving routines. */
+
+static void
+resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
+ gfc_namespace *ns, bool openacc = false)
+{
+ gfc_omp_namelist *n;
+ gfc_expr_list *el;
+ int list;
+ int ifc;
+ bool if_without_mod = false;
+ gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
+ static const char *clause_names[]
+ = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
+ "COPYIN", "UNIFORM", "AFFINITY", "ALIGNED", "LINEAR", "DEPEND", "MAP",
+ "TO", "FROM", "INCLUSIVE", "EXCLUSIVE",
+ "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/,
+ "IN_REDUCTION", "TASK_REDUCTION",
+ "DEVICE_RESIDENT", "LINK", "USE_DEVICE",
+ "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR",
+ "NONTEMPORAL", "ALLOCATE" };
+ STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
+
+ if (omp_clauses == NULL)
+ return;
+
+ if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse)
+ gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L",
+ &code->loc);
+ if (omp_clauses->order_concurrent && omp_clauses->ordered)
+ gfc_error ("ORDER clause must not be used together ORDERED at %L",
+ &code->loc);
+ if (omp_clauses->if_expr)
+ {
+ gfc_expr *expr = omp_clauses->if_expr;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_LOGICAL || expr->rank != 0)
+ gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
+ &expr->where);
+ if_without_mod = true;
+ }
+ for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
+ if (omp_clauses->if_exprs[ifc])
+ {
+ gfc_expr *expr = omp_clauses->if_exprs[ifc];
+ bool ok = true;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_LOGICAL || expr->rank != 0)
+ gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
+ &expr->where);
+ else if (if_without_mod)
+ {
+ gfc_error ("IF clause without modifier at %L used together with "
+ "IF clauses with modifiers",
+ &omp_clauses->if_expr->where);
+ if_without_mod = false;
+ }
+ else
+ switch (code->op)
+ {
+ case EXEC_OMP_CANCEL:
+ ok = ifc == OMP_IF_CANCEL;
+ break;
+
+ case EXEC_OMP_PARALLEL:
+ case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_LOOP:
+ case EXEC_OMP_PARALLEL_MASKED:
+ case EXEC_OMP_PARALLEL_MASTER:
+ case EXEC_OMP_PARALLEL_SECTIONS:
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ ok = ifc == OMP_IF_PARALLEL;
+ break;
+
+ case EXEC_OMP_PARALLEL_DO_SIMD:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_SIMD;
+ break;
+
+ case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
+ case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
+ ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_TASKLOOP;
+ break;
+
+ case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
+ case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
+ ok = (ifc == OMP_IF_PARALLEL
+ || ifc == OMP_IF_TASKLOOP
+ || ifc == OMP_IF_SIMD);
+ break;
+
+ case EXEC_OMP_SIMD:
+ case EXEC_OMP_DO_SIMD:
+ case EXEC_OMP_DISTRIBUTE_SIMD:
+ case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
+ ok = ifc == OMP_IF_SIMD;
+ break;
+
+ case EXEC_OMP_TASK:
+ ok = ifc == OMP_IF_TASK;
+ break;
+
+ case EXEC_OMP_TASKLOOP:
+ case EXEC_OMP_MASKED_TASKLOOP:
+ case EXEC_OMP_MASTER_TASKLOOP:
+ ok = ifc == OMP_IF_TASKLOOP;
+ break;
+
+ case EXEC_OMP_TASKLOOP_SIMD:
+ case EXEC_OMP_MASKED_TASKLOOP_SIMD:
+ case EXEC_OMP_MASTER_TASKLOOP_SIMD:
+ ok = ifc == OMP_IF_TASKLOOP || ifc == OMP_IF_SIMD;
+ break;
+
+ case EXEC_OMP_TARGET:
+ case EXEC_OMP_TARGET_TEAMS:
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
+ case EXEC_OMP_TARGET_TEAMS_LOOP:
+ ok = ifc == OMP_IF_TARGET;
+ break;
+
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
+ case EXEC_OMP_TARGET_SIMD:
+ ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_SIMD;
+ break;
+
+ case EXEC_OMP_TARGET_DATA:
+ ok = ifc == OMP_IF_TARGET_DATA;
+ break;
+
+ case EXEC_OMP_TARGET_UPDATE:
+ ok = ifc == OMP_IF_TARGET_UPDATE;
+ break;
+
+ case EXEC_OMP_TARGET_ENTER_DATA:
+ ok = ifc == OMP_IF_TARGET_ENTER_DATA;
+ break;
+
+ case EXEC_OMP_TARGET_EXIT_DATA:
+ ok = ifc == OMP_IF_TARGET_EXIT_DATA;
+ break;
+
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_TARGET_PARALLEL:
+ case EXEC_OMP_TARGET_PARALLEL_DO:
+ case EXEC_OMP_TARGET_PARALLEL_LOOP:
+ ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL;
+ break;
+
+ case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ ok = (ifc == OMP_IF_TARGET
+ || ifc == OMP_IF_PARALLEL
+ || ifc == OMP_IF_SIMD);
+ break;
+
+ default:
+ ok = false;
+ break;
+ }
+ if (!ok)
+ {
+ static const char *ifs[] = {
+ "CANCEL",
+ "PARALLEL",
+ "SIMD",
+ "TASK",
+ "TASKLOOP",
+ "TARGET",
+ "TARGET DATA",
+ "TARGET UPDATE",
+ "TARGET ENTER DATA",
+ "TARGET EXIT DATA"
+ };
+ gfc_error ("IF clause modifier %s at %L not appropriate for "
+ "the current OpenMP construct", ifs[ifc], &expr->where);
+ }
+ }
+
+ if (omp_clauses->final_expr)
+ {
+ gfc_expr *expr = omp_clauses->final_expr;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_LOGICAL || expr->rank != 0)
+ gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
+ &expr->where);
+ }
+ if (omp_clauses->num_threads)
+ resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS");
+ if (omp_clauses->chunk_size)
+ {
+ gfc_expr *expr = omp_clauses->chunk_size;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_INTEGER || expr->rank != 0)
+ gfc_error ("SCHEDULE clause's chunk_size at %L requires "
+ "a scalar INTEGER expression", &expr->where);
+ else if (expr->expr_type == EXPR_CONSTANT
+ && expr->ts.type == BT_INTEGER
+ && mpz_sgn (expr->value.integer) <= 0)
+ gfc_warning (0, "INTEGER expression of SCHEDULE clause's chunk_size "
+ "at %L must be positive", &expr->where);
+ }
+ if (omp_clauses->sched_kind != OMP_SCHED_NONE
+ && omp_clauses->sched_nonmonotonic)
+ {
+ if (omp_clauses->sched_monotonic)
+ gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers "
+ "specified at %L", &code->loc);
+ else if (omp_clauses->ordered)
+ gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED "
+ "clause at %L", &code->loc);
+ }
+
+ if (omp_clauses->depobj
+ && (!gfc_resolve_expr (omp_clauses->depobj)
+ || omp_clauses->depobj->ts.type != BT_INTEGER
+ || omp_clauses->depobj->ts.kind != 2 * gfc_index_integer_kind
+ || omp_clauses->depobj->rank != 0))
+ gfc_error ("DEPOBJ in DEPOBJ construct at %L shall be a scalar integer "
+ "of OMP_DEPEND_KIND kind", &omp_clauses->depobj->where);
+
+ /* Check that no symbol appears on multiple clauses, except that
+ a symbol can appear on both firstprivate and lastprivate. */
+ for (list = 0; list < OMP_LIST_NUM; list++)
+ for (n = omp_clauses->lists[list]; n; n = n->next)
+ {
+ n->sym->mark = 0;
+ n->sym->comp_mark = 0;
+ if (n->sym->attr.flavor == FL_VARIABLE
+ || n->sym->attr.proc_pointer
+ || (!code && (!n->sym->attr.dummy || n->sym->ns != ns)))
+ {
+ if (!code && (!n->sym->attr.dummy || n->sym->ns != ns))
+ gfc_error ("Variable %qs is not a dummy argument at %L",
+ n->sym->name, &n->where);
+ continue;
+ }
+ if (n->sym->attr.flavor == FL_PROCEDURE
+ && n->sym->result == n->sym
+ && n->sym->attr.function)
+ {
+ if (gfc_current_ns->proc_name == n->sym
+ || (gfc_current_ns->parent
+ && gfc_current_ns->parent->proc_name == n->sym))
+ continue;
+ if (gfc_current_ns->proc_name->attr.entry_master)
+ {
+ gfc_entry_list *el = gfc_current_ns->entries;
+ for (; el; el = el->next)
+ if (el->sym == n->sym)
+ break;
+ if (el)
+ continue;
+ }
+ if (gfc_current_ns->parent
+ && gfc_current_ns->parent->proc_name->attr.entry_master)
+ {
+ gfc_entry_list *el = gfc_current_ns->parent->entries;
+ for (; el; el = el->next)
+ if (el->sym == n->sym)
+ break;
+ if (el)
+ continue;
+ }
+ }
+ if (list == OMP_LIST_MAP
+ && n->sym->attr.flavor == FL_PARAMETER)
+ {
+ if (openacc)
+ gfc_error ("Object %qs is not a variable at %L; parameters"
+ " cannot be and need not be copied", n->sym->name,
+ &n->where);
+ else
+ gfc_error ("Object %qs is not a variable at %L; parameters"
+ " cannot be and need not be mapped", n->sym->name,
+ &n->where);
+ }
+ else
+ gfc_error ("Object %qs is not a variable at %L", n->sym->name,
+ &n->where);
+ }
+ if (omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]
+ && code->op != EXEC_OMP_DO
+ && code->op != EXEC_OMP_SIMD
+ && code->op != EXEC_OMP_DO_SIMD
+ && code->op != EXEC_OMP_PARALLEL_DO
+ && code->op != EXEC_OMP_PARALLEL_DO_SIMD)
+ gfc_error ("%<inscan%> REDUCTION clause on construct other than DO, SIMD, "
+ "DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L",
+ &omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where);
+
+ for (list = 0; list < OMP_LIST_NUM; list++)
+ if (list != OMP_LIST_FIRSTPRIVATE
+ && list != OMP_LIST_LASTPRIVATE
+ && list != OMP_LIST_ALIGNED
+ && list != OMP_LIST_DEPEND
+ && (list != OMP_LIST_MAP || openacc)
+ && list != OMP_LIST_FROM
+ && list != OMP_LIST_TO
+ && (list != OMP_LIST_REDUCTION || !openacc)
+ && list != OMP_LIST_REDUCTION_INSCAN
+ && list != OMP_LIST_REDUCTION_TASK
+ && list != OMP_LIST_IN_REDUCTION
+ && list != OMP_LIST_TASK_REDUCTION
+ && list != OMP_LIST_ALLOCATE)
+ for (n = omp_clauses->lists[list]; n; n = n->next)
+ {
+ bool component_ref_p = false;
+
+ /* Allow multiple components of the same (e.g. derived-type)
+ variable here. Duplicate components are detected elsewhere. */
+ if (n->expr && n->expr->expr_type == EXPR_VARIABLE)
+ for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ component_ref_p = true;
+ if ((!component_ref_p && n->sym->comp_mark)
+ || (component_ref_p && n->sym->mark))
+ gfc_error ("Symbol %qs has mixed component and non-component "
+ "accesses at %L", n->sym->name, &n->where);
+ else if (n->sym->mark)
+ gfc_error ("Symbol %qs present on multiple clauses at %L",
+ n->sym->name, &n->where);
+ else
+ {
+ if (component_ref_p)
+ n->sym->comp_mark = 1;
+ else
+ n->sym->mark = 1;
+ }
+ }
+
+ gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
+ for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
+ for (n = omp_clauses->lists[list]; n; n = n->next)
+ if (n->sym->mark)
+ {
+ gfc_error ("Symbol %qs present on multiple clauses at %L",
+ n->sym->name, &n->where);
+ n->sym->mark = 0;
+ }
+
+ for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
+ {
+ if (n->sym->mark)
+ gfc_error ("Symbol %qs present on multiple clauses at %L",
+ n->sym->name, &n->where);
+ else
+ n->sym->mark = 1;
+ }
+ for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
+ n->sym->mark = 0;
+
+ for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
+ {
+ if (n->sym->mark)
+ gfc_error ("Symbol %qs present on multiple clauses at %L",
+ n->sym->name, &n->where);
+ else
+ n->sym->mark = 1;
+ }
+
+ for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
+ n->sym->mark = 0;
+
+ for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
+ {
+ if (n->sym->mark)
+ gfc_error ("Symbol %qs present on multiple clauses at %L",
+ n->sym->name, &n->where);
+ else
+ n->sym->mark = 1;
+ }
+
+ if (omp_clauses->lists[OMP_LIST_ALLOCATE])
+ {
+ for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
+ if (n->expr && (n->expr->ts.type != BT_INTEGER
+ || n->expr->ts.kind != gfc_c_intptr_kind))
+ {
+ gfc_error ("Expected integer expression of the "
+ "'omp_allocator_handle_kind' kind at %L",
+ &n->expr->where);
+ break;
+ }
+
+ /* Check for 2 things here.
+ 1. There is no duplication of variable in allocate clause.
+ 2. Variable in allocate clause are also present in some
+ privatization clase (non-composite case). */
+ for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
+ n->sym->mark = 0;
+
+ gfc_omp_namelist *prev = NULL;
+ for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n;)
+ {
+ if (n->sym->mark == 1)
+ {
+ gfc_warning (0, "%qs appears more than once in %<allocate%> "
+ "clauses at %L" , n->sym->name, &n->where);
+ /* We have already seen this variable so it is a duplicate.
+ Remove it. */
+ if (prev != NULL && prev->next == n)
+ {
+ prev->next = n->next;
+ n->next = NULL;
+ gfc_free_omp_namelist (n, 0);
+ n = prev->next;
+ }
+ continue;
+ }
+ n->sym->mark = 1;
+ prev = n;
+ n = n->next;
+ }
+
+ /* Non-composite constructs. */
+ if (code && code->op < EXEC_OMP_DO_SIMD)
+ {
+ for (list = 0; list < OMP_LIST_NUM; list++)
+ switch (list)
+ {
+ case OMP_LIST_PRIVATE:
+ case OMP_LIST_FIRSTPRIVATE:
+ case OMP_LIST_LASTPRIVATE:
+ case OMP_LIST_REDUCTION:
+ case OMP_LIST_REDUCTION_INSCAN:
+ case OMP_LIST_REDUCTION_TASK:
+ case OMP_LIST_IN_REDUCTION:
+ case OMP_LIST_TASK_REDUCTION:
+ case OMP_LIST_LINEAR:
+ for (n = omp_clauses->lists[list]; n; n = n->next)
+ n->sym->mark = 0;
+ break;
+ default:
+ break;
+ }
+
+ for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
+ if (n->sym->mark == 1)
+ gfc_error ("%qs specified in 'allocate' clause at %L but not "
+ "in an explicit privatization clause",
+ n->sym->name, &n->where);
+ }
+ }
+
+ /* OpenACC reductions. */
+ if (openacc)
+ {
+ for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
+ n->sym->mark = 0;
+
+ for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
+ {
+ if (n->sym->mark)
+ gfc_error ("Symbol %qs present on multiple clauses at %L",
+ n->sym->name, &n->where);
+ else
+ n->sym->mark = 1;
+
+ /* OpenACC does not support reductions on arrays. */
+ if (n->sym->as)
+ gfc_error ("Array %qs is not permitted in reduction at %L",
+ n->sym->name, &n->where);
+ }
+ }
+
+ for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
+ n->sym->mark = 0;
+ for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next)
+ if (n->expr == NULL)
+ n->sym->mark = 1;
+ for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
+ {
+ if (n->expr == NULL && n->sym->mark)
+ gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
+ n->sym->name, &n->where);
+ else
+ n->sym->mark = 1;
+ }
+
+ bool has_inscan = false, has_notinscan = false;
+ for (list = 0; list < OMP_LIST_NUM; list++)
+ if ((n = omp_clauses->lists[list]) != NULL)
+ {
+ const char *name = clause_names[list];
+
+ switch (list)
+ {
+ case OMP_LIST_COPYIN:
+ for (; n != NULL; n = n->next)
+ {
+ if (!n->sym->attr.threadprivate)
+ gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
+ " at %L", n->sym->name, &n->where);
+ }
+ break;
+ case OMP_LIST_COPYPRIVATE:
+ for (; n != NULL; n = n->next)
+ {
+ if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
+ gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
+ "at %L", n->sym->name, &n->where);
+ if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
+ gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
+ "at %L", n->sym->name, &n->where);
+ }
+ break;
+ case OMP_LIST_SHARED:
+ for (; n != NULL; n = n->next)
+ {
+ if (n->sym->attr.threadprivate)
+ gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
+ "%L", n->sym->name, &n->where);
+ if (n->sym->attr.cray_pointee)
+ gfc_error ("Cray pointee %qs in SHARED clause at %L",
+ n->sym->name, &n->where);
+ if (n->sym->attr.associate_var)
+ gfc_error ("ASSOCIATE name %qs in SHARED clause at %L",
+ n->sym->name, &n->where);
+ if (omp_clauses->detach
+ && n->sym == omp_clauses->detach->symtree->n.sym)
+ gfc_error ("DETACH event handle %qs in SHARED clause at %L",
+ n->sym->name, &n->where);
+ }
+ break;
+ case OMP_LIST_ALIGNED:
+ for (; n != NULL; n = n->next)
+ {
+ if (!n->sym->attr.pointer
+ && !n->sym->attr.allocatable
+ && !n->sym->attr.cray_pointer
+ && (n->sym->ts.type != BT_DERIVED
+ || (n->sym->ts.u.derived->from_intmod
+ != INTMOD_ISO_C_BINDING)
+ || (n->sym->ts.u.derived->intmod_sym_id
+ != ISOCBINDING_PTR)))
+ gfc_error ("%qs in ALIGNED clause must be POINTER, "
+ "ALLOCATABLE, Cray pointer or C_PTR at %L",
+ n->sym->name, &n->where);
+ else if (n->expr)
+ {
+ gfc_expr *expr = n->expr;
+ int alignment = 0;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_INTEGER
+ || expr->rank != 0
+ || gfc_extract_int (expr, &alignment)
+ || alignment <= 0)
+ gfc_error ("%qs in ALIGNED clause at %L requires a scalar "
+ "positive constant integer alignment "
+ "expression", n->sym->name, &n->where);
+ }
+ }
+ break;
+ case OMP_LIST_AFFINITY:
+ case OMP_LIST_DEPEND:
+ case OMP_LIST_MAP:
+ case OMP_LIST_TO:
+ case OMP_LIST_FROM:
+ case OMP_LIST_CACHE:
+ for (; n != NULL; n = n->next)
+ {
+ if ((list == OMP_LIST_DEPEND || list == OMP_LIST_AFFINITY)
+ && n->u2.ns && !n->u2.ns->resolved)
+ {
+ n->u2.ns->resolved = 1;
+ for (gfc_symbol *sym = n->u2.ns->proc_name; sym;
+ sym = sym->tlink)
+ {
+ gfc_constructor *c;
+ c = gfc_constructor_first (sym->value->value.constructor);
+ if (!gfc_resolve_expr (c->expr)
+ || c->expr->ts.type != BT_INTEGER
+ || c->expr->rank != 0)
+ gfc_error ("Scalar integer expression for range begin"
+ " expected at %L", &c->expr->where);
+ c = gfc_constructor_next (c);
+ if (!gfc_resolve_expr (c->expr)
+ || c->expr->ts.type != BT_INTEGER
+ || c->expr->rank != 0)
+ gfc_error ("Scalar integer expression for range end "
+ "expected at %L", &c->expr->where);
+ c = gfc_constructor_next (c);
+ if (c && (!gfc_resolve_expr (c->expr)
+ || c->expr->ts.type != BT_INTEGER
+ || c->expr->rank != 0))
+ gfc_error ("Scalar integer expression for range step "
+ "expected at %L", &c->expr->where);
+ else if (c
+ && c->expr->expr_type == EXPR_CONSTANT
+ && mpz_cmp_si (c->expr->value.integer, 0) == 0)
+ gfc_error ("Nonzero range step expected at %L",
+ &c->expr->where);
+ }
+ }
+
+ if (list == OMP_LIST_DEPEND)
+ {
+ if (n->u.depend_op == OMP_DEPEND_SINK_FIRST
+ || n->u.depend_op == OMP_DEPEND_SINK)
+ {
+ if (code->op != EXEC_OMP_ORDERED)
+ gfc_error ("SINK dependence type only allowed "
+ "on ORDERED directive at %L", &n->where);
+ else if (omp_clauses->depend_source)
+ {
+ gfc_error ("DEPEND SINK used together with "
+ "DEPEND SOURCE on the same construct "
+ "at %L", &n->where);
+ omp_clauses->depend_source = false;
+ }
+ else if (n->expr)
+ {
+ if (!gfc_resolve_expr (n->expr)
+ || n->expr->ts.type != BT_INTEGER
+ || n->expr->rank != 0)
+ gfc_error ("SINK addend not a constant integer "
+ "at %L", &n->where);
+ }
+ continue;
+ }
+ else if (code->op == EXEC_OMP_ORDERED)
+ gfc_error ("Only SOURCE or SINK dependence types "
+ "are allowed on ORDERED directive at %L",
+ &n->where);
+ else if (n->u.depend_op == OMP_DEPEND_DEPOBJ
+ && !n->expr
+ && (n->sym->ts.type != BT_INTEGER
+ || n->sym->ts.kind
+ != 2 * gfc_index_integer_kind
+ || n->sym->attr.dimension))
+ gfc_error ("Locator %qs at %L in DEPEND clause of depobj "
+ "type shall be a scalar integer of "
+ "OMP_DEPEND_KIND kind", n->sym->name,
+ &n->where);
+ else if (n->u.depend_op == OMP_DEPEND_DEPOBJ
+ && n->expr
+ && (!gfc_resolve_expr (n->expr)
+ || n->expr->ts.type != BT_INTEGER
+ || n->expr->ts.kind
+ != 2 * gfc_index_integer_kind
+ || n->expr->rank != 0))
+ gfc_error ("Locator at %L in DEPEND clause of depobj "
+ "type shall be a scalar integer of "
+ "OMP_DEPEND_KIND kind", &n->expr->where);
+ }
+ gfc_ref *lastref = NULL, *lastslice = NULL;
+ bool resolved = false;
+ if (n->expr)
+ {
+ lastref = n->expr->ref;
+ resolved = gfc_resolve_expr (n->expr);
+
+ /* Look through component refs to find last array
+ reference. */
+ if (resolved)
+ {
+ for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT
+ || ref->type == REF_SUBSTRING
+ || ref->type == REF_INQUIRY)
+ lastref = ref;
+ else if (ref->type == REF_ARRAY)
+ {
+ for (int i = 0; i < ref->u.ar.dimen; i++)
+ if (ref->u.ar.dimen_type[i] == DIMEN_RANGE)
+ lastslice = ref;
+
+ lastref = ref;
+ }
+
+ /* The "!$acc cache" directive allows rectangular
+ subarrays to be specified, with some restrictions
+ on the form of bounds (not implemented).
+ Only raise an error here if we're really sure the
+ array isn't contiguous. An expression such as
+ arr(-n:n,-n:n) could be contiguous even if it looks
+ like it may not be. */
+ if (code->op != EXEC_OACC_UPDATE
+ && list != OMP_LIST_CACHE
+ && list != OMP_LIST_DEPEND
+ && !gfc_is_simply_contiguous (n->expr, false, true)
+ && gfc_is_not_contiguous (n->expr)
+ && !(lastslice
+ && (lastslice->next
+ || lastslice->type != REF_ARRAY)))
+ gfc_error ("Array is not contiguous at %L",
+ &n->where);
+ }
+ }
+ if (lastref
+ || (n->expr
+ && (!resolved || n->expr->expr_type != EXPR_VARIABLE)))
+ {
+ if (!lastslice
+ && lastref
+ && lastref->type == REF_SUBSTRING)
+ gfc_error ("Unexpected substring reference in %s clause "
+ "at %L", name, &n->where);
+ else if (!lastslice
+ && lastref
+ && lastref->type == REF_INQUIRY)
+ {
+ gcc_assert (lastref->u.i == INQUIRY_RE
+ || lastref->u.i == INQUIRY_IM);
+ gfc_error ("Unexpected complex-parts designator "
+ "reference in %s clause at %L",
+ name, &n->where);
+ }
+ else if (!resolved
+ || n->expr->expr_type != EXPR_VARIABLE
+ || (lastslice
+ && (lastslice->next
+ || lastslice->type != REF_ARRAY)))
+ gfc_error ("%qs in %s clause at %L is not a proper "
+ "array section", n->sym->name, name,
+ &n->where);
+ else if (lastslice)
+ {
+ int i;
+ gfc_array_ref *ar = &lastslice->u.ar;
+ for (i = 0; i < ar->dimen; i++)
+ if (ar->stride[i] && code->op != EXEC_OACC_UPDATE)
+ {
+ gfc_error ("Stride should not be specified for "
+ "array section in %s clause at %L",
+ name, &n->where);
+ break;
+ }
+ else if (ar->dimen_type[i] != DIMEN_ELEMENT
+ && ar->dimen_type[i] != DIMEN_RANGE)
+ {
+ gfc_error ("%qs in %s clause at %L is not a "
+ "proper array section",
+ n->sym->name, name, &n->where);
+ break;
+ }
+ else if ((list == OMP_LIST_DEPEND
+ || list == OMP_LIST_AFFINITY)
+ && ar->start[i]
+ && ar->start[i]->expr_type == EXPR_CONSTANT
+ && ar->end[i]
+ && ar->end[i]->expr_type == EXPR_CONSTANT
+ && mpz_cmp (ar->start[i]->value.integer,
+ ar->end[i]->value.integer) > 0)
+ {
+ gfc_error ("%qs in %s clause at %L is a "
+ "zero size array section",
+ n->sym->name,
+ list == OMP_LIST_DEPEND
+ ? "DEPEND" : "AFFINITY", &n->where);
+ break;
+ }
+ }
+ }
+ else if (openacc)
+ {
+ if (list == OMP_LIST_MAP
+ && n->u.map_op == OMP_MAP_FORCE_DEVICEPTR)
+ resolve_oacc_deviceptr_clause (n->sym, n->where, name);
+ else
+ resolve_oacc_data_clauses (n->sym, n->where, name);
+ }
+ else if (list != OMP_LIST_DEPEND
+ && n->sym->as
+ && n->sym->as->type == AS_ASSUMED_SIZE)
+ gfc_error ("Assumed size array %qs in %s clause at %L",
+ n->sym->name, name, &n->where);
+ if (!openacc
+ && list == OMP_LIST_MAP
+ && n->sym->ts.type == BT_DERIVED
+ && n->sym->ts.u.derived->attr.alloc_comp)
+ gfc_error ("List item %qs with allocatable components is not "
+ "permitted in map clause at %L", n->sym->name,
+ &n->where);
+ if (list == OMP_LIST_MAP && !openacc)
+ switch (code->op)
+ {
+ case EXEC_OMP_TARGET:
+ case EXEC_OMP_TARGET_DATA:
+ switch (n->u.map_op)
+ {
+ case OMP_MAP_TO:
+ case OMP_MAP_ALWAYS_TO:
+ case OMP_MAP_FROM:
+ case OMP_MAP_ALWAYS_FROM:
+ case OMP_MAP_TOFROM:
+ case OMP_MAP_ALWAYS_TOFROM:
+ case OMP_MAP_ALLOC:
+ break;
+ default:
+ gfc_error ("TARGET%s with map-type other than TO, "
+ "FROM, TOFROM, or ALLOC on MAP clause "
+ "at %L",
+ code->op == EXEC_OMP_TARGET
+ ? "" : " DATA", &n->where);
+ break;
+ }
+ break;
+ case EXEC_OMP_TARGET_ENTER_DATA:
+ switch (n->u.map_op)
+ {
+ case OMP_MAP_TO:
+ case OMP_MAP_ALWAYS_TO:
+ case OMP_MAP_ALLOC:
+ break;
+ default:
+ gfc_error ("TARGET ENTER DATA with map-type other "
+ "than TO, or ALLOC on MAP clause at %L",
+ &n->where);
+ break;
+ }
+ break;
+ case EXEC_OMP_TARGET_EXIT_DATA:
+ switch (n->u.map_op)
+ {
+ case OMP_MAP_FROM:
+ case OMP_MAP_ALWAYS_FROM:
+ case OMP_MAP_RELEASE:
+ case OMP_MAP_DELETE:
+ break;
+ default:
+ gfc_error ("TARGET EXIT DATA with map-type other "
+ "than FROM, RELEASE, or DELETE on MAP "
+ "clause at %L", &n->where);
+ break;
+ }
+ break;
+ default:
+ break;
+ }
+ }
+
+ if (list != OMP_LIST_DEPEND)
+ for (n = omp_clauses->lists[list]; n != NULL; n = n->next)
+ {
+ n->sym->attr.referenced = 1;
+ if (n->sym->attr.threadprivate)
+ gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
+ n->sym->name, name, &n->where);
+ if (n->sym->attr.cray_pointee)
+ gfc_error ("Cray pointee %qs in %s clause at %L",
+ n->sym->name, name, &n->where);
+ }
+ break;
+ case OMP_LIST_IS_DEVICE_PTR:
+ for (n = omp_clauses->lists[list]; n != NULL; n = n->next)
+ {
+ if (!n->sym->attr.dummy)
+ gfc_error ("Non-dummy object %qs in %s clause at %L",
+ n->sym->name, name, &n->where);
+ if (n->sym->attr.allocatable
+ || (n->sym->ts.type == BT_CLASS
+ && CLASS_DATA (n->sym)->attr.allocatable))
+ gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
+ n->sym->name, name, &n->where);
+ if (n->sym->attr.pointer
+ || (n->sym->ts.type == BT_CLASS
+ && CLASS_DATA (n->sym)->attr.pointer))
+ gfc_error ("POINTER object %qs in %s clause at %L",
+ n->sym->name, name, &n->where);
+ if (n->sym->attr.value)
+ gfc_error ("VALUE object %qs in %s clause at %L",
+ n->sym->name, name, &n->where);
+ }
+ break;
+ case OMP_LIST_USE_DEVICE_PTR:
+ case OMP_LIST_USE_DEVICE_ADDR:
+ /* FIXME: Handle OMP_LIST_USE_DEVICE_PTR. */
+ break;
+ default:
+ for (; n != NULL; n = n->next)
+ {
+ bool bad = false;
+ bool is_reduction = (list == OMP_LIST_REDUCTION
+ || list == OMP_LIST_REDUCTION_INSCAN
+ || list == OMP_LIST_REDUCTION_TASK
+ || list == OMP_LIST_IN_REDUCTION
+ || list == OMP_LIST_TASK_REDUCTION);
+ if (list == OMP_LIST_REDUCTION_INSCAN)
+ has_inscan = true;
+ else if (is_reduction)
+ has_notinscan = true;
+ if (has_inscan && has_notinscan && is_reduction)
+ {
+ gfc_error ("%<inscan%> and non-%<inscan%> %<reduction%> "
+ "clauses on the same construct at %L",
+ &n->where);
+ break;
+ }
+ if (n->sym->attr.threadprivate)
+ gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
+ n->sym->name, name, &n->where);
+ if (n->sym->attr.cray_pointee)
+ gfc_error ("Cray pointee %qs in %s clause at %L",
+ n->sym->name, name, &n->where);
+ if (n->sym->attr.associate_var)
+ gfc_error ("ASSOCIATE name %qs in %s clause at %L",
+ n->sym->name, name, &n->where);
+ if (list != OMP_LIST_PRIVATE && is_reduction)
+ {
+ if (n->sym->attr.proc_pointer)
+ gfc_error ("Procedure pointer %qs in %s clause at %L",
+ n->sym->name, name, &n->where);
+ if (n->sym->attr.pointer)
+ gfc_error ("POINTER object %qs in %s clause at %L",
+ n->sym->name, name, &n->where);
+ if (n->sym->attr.cray_pointer)
+ gfc_error ("Cray pointer %qs in %s clause at %L",
+ n->sym->name, name, &n->where);
+ }
+ if (code
+ && (oacc_is_loop (code)
+ || code->op == EXEC_OACC_PARALLEL
+ || code->op == EXEC_OACC_SERIAL))
+ check_array_not_assumed (n->sym, n->where, name);
+ else if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
+ gfc_error ("Assumed size array %qs in %s clause at %L",
+ n->sym->name, name, &n->where);
+ if (n->sym->attr.in_namelist && !is_reduction)
+ gfc_error ("Variable %qs in %s clause is used in "
+ "NAMELIST statement at %L",
+ n->sym->name, name, &n->where);
+ if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
+ switch (list)
+ {
+ case OMP_LIST_PRIVATE:
+ case OMP_LIST_LASTPRIVATE:
+ case OMP_LIST_LINEAR:
+ /* case OMP_LIST_REDUCTION: */
+ gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
+ n->sym->name, name, &n->where);
+ break;
+ default:
+ break;
+ }
+ if (omp_clauses->detach
+ && (list == OMP_LIST_PRIVATE
+ || list == OMP_LIST_FIRSTPRIVATE
+ || list == OMP_LIST_LASTPRIVATE)
+ && n->sym == omp_clauses->detach->symtree->n.sym)
+ gfc_error ("DETACH event handle %qs in %s clause at %L",
+ n->sym->name, name, &n->where);
+ switch (list)
+ {
+ case OMP_LIST_REDUCTION_TASK:
+ if (code
+ && (code->op == EXEC_OMP_LOOP
+ || code->op == EXEC_OMP_TASKLOOP
+ || code->op == EXEC_OMP_TASKLOOP_SIMD
+ || code->op == EXEC_OMP_MASKED_TASKLOOP
+ || code->op == EXEC_OMP_MASKED_TASKLOOP_SIMD
+ || code->op == EXEC_OMP_MASTER_TASKLOOP
+ || code->op == EXEC_OMP_MASTER_TASKLOOP_SIMD
+ || code->op == EXEC_OMP_PARALLEL_LOOP
+ || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP
+ || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
+ || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP
+ || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
+ || code->op == EXEC_OMP_TARGET_PARALLEL_LOOP
+ || code->op == EXEC_OMP_TARGET_TEAMS_LOOP
+ || code->op == EXEC_OMP_TEAMS
+ || code->op == EXEC_OMP_TEAMS_DISTRIBUTE
+ || code->op == EXEC_OMP_TEAMS_LOOP))
+ {
+ gfc_error ("Only DEFAULT permitted as reduction-"
+ "modifier in REDUCTION clause at %L",
+ &n->where);
+ break;
+ }
+ gcc_fallthrough ();
+ case OMP_LIST_REDUCTION:
+ case OMP_LIST_IN_REDUCTION:
+ case OMP_LIST_TASK_REDUCTION:
+ case OMP_LIST_REDUCTION_INSCAN:
+ switch (n->u.reduction_op)
+ {
+ case OMP_REDUCTION_PLUS:
+ case OMP_REDUCTION_TIMES:
+ case OMP_REDUCTION_MINUS:
+ if (!gfc_numeric_ts (&n->sym->ts))
+ bad = true;
+ break;
+ case OMP_REDUCTION_AND:
+ case OMP_REDUCTION_OR:
+ case OMP_REDUCTION_EQV:
+ case OMP_REDUCTION_NEQV:
+ if (n->sym->ts.type != BT_LOGICAL)
+ bad = true;
+ break;
+ case OMP_REDUCTION_MAX:
+ case OMP_REDUCTION_MIN:
+ if (n->sym->ts.type != BT_INTEGER
+ && n->sym->ts.type != BT_REAL)
+ bad = true;
+ break;
+ case OMP_REDUCTION_IAND:
+ case OMP_REDUCTION_IOR:
+ case OMP_REDUCTION_IEOR:
+ if (n->sym->ts.type != BT_INTEGER)
+ bad = true;
+ break;
+ case OMP_REDUCTION_USER:
+ bad = true;
+ break;
+ default:
+ break;
+ }
+ if (!bad)
+ n->u2.udr = NULL;
+ else
+ {
+ const char *udr_name = NULL;
+ if (n->u2.udr)
+ {
+ udr_name = n->u2.udr->udr->name;
+ n->u2.udr->udr
+ = gfc_find_omp_udr (NULL, udr_name,
+ &n->sym->ts);
+ if (n->u2.udr->udr == NULL)
+ {
+ free (n->u2.udr);
+ n->u2.udr = NULL;
+ }
+ }
+ if (n->u2.udr == NULL)
+ {
+ if (udr_name == NULL)
+ switch (n->u.reduction_op)
+ {
+ case OMP_REDUCTION_PLUS:
+ case OMP_REDUCTION_TIMES:
+ case OMP_REDUCTION_MINUS:
+ case OMP_REDUCTION_AND:
+ case OMP_REDUCTION_OR:
+ case OMP_REDUCTION_EQV:
+ case OMP_REDUCTION_NEQV:
+ udr_name = gfc_op2string ((gfc_intrinsic_op)
+ n->u.reduction_op);
+ break;
+ case OMP_REDUCTION_MAX:
+ udr_name = "max";
+ break;
+ case OMP_REDUCTION_MIN:
+ udr_name = "min";
+ break;
+ case OMP_REDUCTION_IAND:
+ udr_name = "iand";
+ break;
+ case OMP_REDUCTION_IOR:
+ udr_name = "ior";
+ break;
+ case OMP_REDUCTION_IEOR:
+ udr_name = "ieor";
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ gfc_error ("!$OMP DECLARE REDUCTION %s not found "
+ "for type %s at %L", udr_name,
+ gfc_typename (&n->sym->ts), &n->where);
+ }
+ else
+ {
+ gfc_omp_udr *udr = n->u2.udr->udr;
+ n->u.reduction_op = OMP_REDUCTION_USER;
+ n->u2.udr->combiner
+ = resolve_omp_udr_clause (n, udr->combiner_ns,
+ udr->omp_out,
+ udr->omp_in);
+ if (udr->initializer_ns)
+ n->u2.udr->initializer
+ = resolve_omp_udr_clause (n,
+ udr->initializer_ns,
+ udr->omp_priv,
+ udr->omp_orig);
+ }
+ }
+ break;
+ case OMP_LIST_LINEAR:
+ if (code
+ && n->u.linear_op != OMP_LINEAR_DEFAULT
+ && n->u.linear_op != linear_op)
+ {
+ gfc_error ("LINEAR clause modifier used on DO or SIMD"
+ " construct at %L", &n->where);
+ linear_op = n->u.linear_op;
+ }
+ else if (omp_clauses->orderedc)
+ gfc_error ("LINEAR clause specified together with "
+ "ORDERED clause with argument at %L",
+ &n->where);
+ else if (n->u.linear_op != OMP_LINEAR_REF
+ && n->sym->ts.type != BT_INTEGER)
+ gfc_error ("LINEAR variable %qs must be INTEGER "
+ "at %L", n->sym->name, &n->where);
+ else if ((n->u.linear_op == OMP_LINEAR_REF
+ || n->u.linear_op == OMP_LINEAR_UVAL)
+ && n->sym->attr.value)
+ gfc_error ("LINEAR dummy argument %qs with VALUE "
+ "attribute with %s modifier at %L",
+ n->sym->name,
+ n->u.linear_op == OMP_LINEAR_REF
+ ? "REF" : "UVAL", &n->where);
+ else if (n->expr)
+ {
+ gfc_expr *expr = n->expr;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_INTEGER
+ || expr->rank != 0)
+ gfc_error ("%qs in LINEAR clause at %L requires "
+ "a scalar integer linear-step expression",
+ n->sym->name, &n->where);
+ else if (!code && expr->expr_type != EXPR_CONSTANT)
+ {
+ if (expr->expr_type == EXPR_VARIABLE
+ && expr->symtree->n.sym->attr.dummy
+ && expr->symtree->n.sym->ns == ns)
+ {
+ gfc_omp_namelist *n2;
+ for (n2 = omp_clauses->lists[OMP_LIST_UNIFORM];
+ n2; n2 = n2->next)
+ if (n2->sym == expr->symtree->n.sym)
+ break;
+ if (n2)
+ break;
+ }
+ gfc_error ("%qs in LINEAR clause at %L requires "
+ "a constant integer linear-step "
+ "expression or dummy argument "
+ "specified in UNIFORM clause",
+ n->sym->name, &n->where);
+ }
+ }
+ break;
+ /* Workaround for PR middle-end/26316, nothing really needs
+ to be done here for OMP_LIST_PRIVATE. */
+ case OMP_LIST_PRIVATE:
+ gcc_assert (code && code->op != EXEC_NOP);
+ break;
+ case OMP_LIST_USE_DEVICE:
+ if (n->sym->attr.allocatable
+ || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
+ && CLASS_DATA (n->sym)->attr.allocatable))
+ gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
+ n->sym->name, name, &n->where);
+ if (n->sym->ts.type == BT_CLASS
+ && CLASS_DATA (n->sym)
+ && CLASS_DATA (n->sym)->attr.class_pointer)
+ gfc_error ("POINTER object %qs of polymorphic type in "
+ "%s clause at %L", n->sym->name, name,
+ &n->where);
+ if (n->sym->attr.cray_pointer)
+ gfc_error ("Cray pointer object %qs in %s clause at %L",
+ n->sym->name, name, &n->where);
+ else if (n->sym->attr.cray_pointee)
+ gfc_error ("Cray pointee object %qs in %s clause at %L",
+ n->sym->name, name, &n->where);
+ else if (n->sym->attr.flavor == FL_VARIABLE
+ && !n->sym->as
+ && !n->sym->attr.pointer)
+ gfc_error ("%s clause variable %qs at %L is neither "
+ "a POINTER nor an array", name,
+ n->sym->name, &n->where);
+ /* FALLTHRU */
+ case OMP_LIST_DEVICE_RESIDENT:
+ check_symbol_not_pointer (n->sym, n->where, name);
+ check_array_not_assumed (n->sym, n->where, name);
+ break;
+ default:
+ break;
+ }
+ }
+ break;
+ }
+ }
+ /* OpenMP 5.1: use_device_ptr acts like use_device_addr, except for
+ type(c_ptr). */
+ if (omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR])
+ {
+ gfc_omp_namelist *n_prev, *n_next, *n_addr;
+ n_addr = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
+ for (; n_addr && n_addr->next; n_addr = n_addr->next)
+ ;
+ n_prev = NULL;
+ n = omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR];
+ while (n)
+ {
+ n_next = n->next;
+ if (n->sym->ts.type != BT_DERIVED
+ || n->sym->ts.u.derived->ts.f90_type != BT_VOID)
+ {
+ n->next = NULL;
+ if (n_addr)
+ n_addr->next = n;
+ else
+ omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n;
+ n_addr = n;
+ if (n_prev)
+ n_prev->next = n_next;
+ else
+ omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] = n_next;
+ }
+ else
+ n_prev = n;
+ n = n_next;
+ }
+ }
+ if (omp_clauses->safelen_expr)
+ resolve_positive_int_expr (omp_clauses->safelen_expr, "SAFELEN");
+ if (omp_clauses->simdlen_expr)
+ resolve_positive_int_expr (omp_clauses->simdlen_expr, "SIMDLEN");
+ if (omp_clauses->num_teams_lower)
+ resolve_positive_int_expr (omp_clauses->num_teams_lower, "NUM_TEAMS");
+ if (omp_clauses->num_teams_upper)
+ resolve_positive_int_expr (omp_clauses->num_teams_upper, "NUM_TEAMS");
+ if (omp_clauses->num_teams_lower
+ && omp_clauses->num_teams_lower->expr_type == EXPR_CONSTANT
+ && omp_clauses->num_teams_upper->expr_type == EXPR_CONSTANT
+ && mpz_cmp (omp_clauses->num_teams_lower->value.integer,
+ omp_clauses->num_teams_upper->value.integer) > 0)
+ gfc_warning (0, "NUM_TEAMS lower bound at %L larger than upper bound at %L",
+ &omp_clauses->num_teams_lower->where,
+ &omp_clauses->num_teams_upper->where);
+ if (omp_clauses->device)
+ resolve_nonnegative_int_expr (omp_clauses->device, "DEVICE");
+ if (omp_clauses->filter)
+ resolve_nonnegative_int_expr (omp_clauses->filter, "FILTER");
+ if (omp_clauses->hint)
+ {
+ resolve_scalar_int_expr (omp_clauses->hint, "HINT");
+ if (omp_clauses->hint->ts.type != BT_INTEGER
+ || omp_clauses->hint->expr_type != EXPR_CONSTANT
+ || mpz_sgn (omp_clauses->hint->value.integer) < 0)
+ gfc_error ("Value of HINT clause at %L shall be a valid "
+ "constant hint expression", &omp_clauses->hint->where);
+ }
+ if (omp_clauses->priority)
+ resolve_nonnegative_int_expr (omp_clauses->priority, "PRIORITY");
+ if (omp_clauses->dist_chunk_size)
+ {
+ gfc_expr *expr = omp_clauses->dist_chunk_size;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_INTEGER || expr->rank != 0)
+ gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
+ "a scalar INTEGER expression", &expr->where);
+ }
+ if (omp_clauses->thread_limit)
+ resolve_positive_int_expr (omp_clauses->thread_limit, "THREAD_LIMIT");
+ if (omp_clauses->grainsize)
+ resolve_positive_int_expr (omp_clauses->grainsize, "GRAINSIZE");
+ if (omp_clauses->num_tasks)
+ resolve_positive_int_expr (omp_clauses->num_tasks, "NUM_TASKS");
+ if (omp_clauses->async)
+ if (omp_clauses->async_expr)
+ resolve_scalar_int_expr (omp_clauses->async_expr, "ASYNC");
+ if (omp_clauses->num_gangs_expr)
+ resolve_positive_int_expr (omp_clauses->num_gangs_expr, "NUM_GANGS");
+ if (omp_clauses->num_workers_expr)
+ resolve_positive_int_expr (omp_clauses->num_workers_expr, "NUM_WORKERS");
+ if (omp_clauses->vector_length_expr)
+ resolve_positive_int_expr (omp_clauses->vector_length_expr,
+ "VECTOR_LENGTH");
+ if (omp_clauses->gang_num_expr)
+ resolve_positive_int_expr (omp_clauses->gang_num_expr, "GANG");
+ if (omp_clauses->gang_static_expr)
+ resolve_positive_int_expr (omp_clauses->gang_static_expr, "GANG");
+ if (omp_clauses->worker_expr)
+ resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER");
+ if (omp_clauses->vector_expr)
+ resolve_positive_int_expr (omp_clauses->vector_expr, "VECTOR");
+ for (el = omp_clauses->wait_list; el; el = el->next)
+ resolve_scalar_int_expr (el->expr, "WAIT");
+ if (omp_clauses->collapse && omp_clauses->tile_list)
+ gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc);
+ if (omp_clauses->depend_source && code->op != EXEC_OMP_ORDERED)
+ gfc_error ("SOURCE dependence type only allowed "
+ "on ORDERED directive at %L", &code->loc);
+ if (omp_clauses->message)
+ {
+ gfc_expr *expr = omp_clauses->message;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.kind != gfc_default_character_kind
+ || expr->ts.type != BT_CHARACTER || expr->rank != 0)
+ gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
+ "CHARACTER expression", &expr->where);
+ }
+ if (!openacc
+ && code
+ && omp_clauses->lists[OMP_LIST_MAP] == NULL
+ && omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] == NULL
+ && omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] == NULL)
+ {
+ const char *p = NULL;
+ switch (code->op)
+ {
+ case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break;
+ case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break;
+ default: break;
+ }
+ if (code->op == EXEC_OMP_TARGET_DATA)
+ gfc_error ("TARGET DATA must contain at least one MAP, USE_DEVICE_PTR, "
+ "or USE_DEVICE_ADDR clause at %L", &code->loc);
+ else if (p)
+ gfc_error ("%s must contain at least one MAP clause at %L",
+ p, &code->loc);
+ }
+ if (!openacc && omp_clauses->mergeable && omp_clauses->detach)
+ gfc_error ("%<DETACH%> clause at %L must not be used together with "
+ "%<MERGEABLE%> clause", &omp_clauses->detach->where);
+}
+
+
+/* Return true if SYM is ever referenced in EXPR except in the SE node. */
+
+static bool
+expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
+{
+ gfc_actual_arglist *arg;
+ if (e == NULL || e == se)
+ return false;
+ switch (e->expr_type)
+ {
+ case EXPR_CONSTANT:
+ case EXPR_NULL:
+ case EXPR_VARIABLE:
+ case EXPR_STRUCTURE:
+ case EXPR_ARRAY:
+ if (e->symtree != NULL
+ && e->symtree->n.sym == s)
+ return true;
+ return false;
+ case EXPR_SUBSTRING:
+ if (e->ref != NULL
+ && (expr_references_sym (e->ref->u.ss.start, s, se)
+ || expr_references_sym (e->ref->u.ss.end, s, se)))
+ return true;
+ return false;
+ case EXPR_OP:
+ if (expr_references_sym (e->value.op.op2, s, se))
+ return true;
+ return expr_references_sym (e->value.op.op1, s, se);
+ case EXPR_FUNCTION:
+ for (arg = e->value.function.actual; arg; arg = arg->next)
+ if (expr_references_sym (arg->expr, s, se))
+ return true;
+ return false;
+ default:
+ gcc_unreachable ();
+ }
+}
+
+
+/* If EXPR is a conversion function that widens the type
+ if WIDENING is true or narrows the type if NARROW is true,
+ return the inner expression, otherwise return NULL. */
+
+static gfc_expr *
+is_conversion (gfc_expr *expr, bool narrowing, bool widening)
+{
+ gfc_typespec *ts1, *ts2;
+
+ if (expr->expr_type != EXPR_FUNCTION
+ || expr->value.function.isym == NULL
+ || expr->value.function.esym != NULL
+ || expr->value.function.isym->id != GFC_ISYM_CONVERSION
+ || (!narrowing && !widening))
+ return NULL;
+
+ if (narrowing && widening)
+ return expr->value.function.actual->expr;
+
+ if (widening)
+ {
+ ts1 = &expr->ts;
+ ts2 = &expr->value.function.actual->expr->ts;
+ }
+ else
+ {
+ ts1 = &expr->value.function.actual->expr->ts;
+ ts2 = &expr->ts;
+ }
+
+ if (ts1->type > ts2->type
+ || (ts1->type == ts2->type && ts1->kind > ts2->kind))
+ return expr->value.function.actual->expr;
+
+ return NULL;
+}
+
+static bool
+is_scalar_intrinsic_expr (gfc_expr *expr, bool must_be_var, bool conv_ok)
+{
+ if (must_be_var
+ && (expr->expr_type != EXPR_VARIABLE || !expr->symtree)
+ && (!conv_ok || !is_conversion (expr, true, true)))
+ return false;
+ return (expr->rank == 0
+ && !gfc_is_coindexed (expr)
+ && (expr->ts.type == BT_INTEGER
+ || expr->ts.type == BT_REAL
+ || expr->ts.type == BT_COMPLEX
+ || expr->ts.type == BT_LOGICAL));
+}
+
+static void
+resolve_omp_atomic (gfc_code *code)
+{
+ gfc_code *atomic_code = code->block;
+ gfc_symbol *var;
+ gfc_expr *stmt_expr2, *capt_expr2;
+ gfc_omp_atomic_op aop
+ = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
+ & GFC_OMP_ATOMIC_MASK);
+ gfc_code *stmt = NULL, *capture_stmt = NULL;
+ gfc_expr *comp_cond = NULL;
+ locus *loc = NULL;
+
+ code = code->block->next;
+ /* resolve_blocks asserts this is initially EXEC_ASSIGN or EXEC_IF
+ If it changed to EXEC_NOP, assume an error has been emitted already. */
+ if (code->op == EXEC_NOP)
+ return;
+
+ if (atomic_code->ext.omp_clauses->compare
+ && atomic_code->ext.omp_clauses->capture)
+ {
+ /* Must be either "if (x == e) then; x = d; else; v = x; end if"
+ or "v = expr" followed/preceded by
+ "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
+ gfc_code *next = code;
+ if (code->op == EXEC_ASSIGN)
+ {
+ capture_stmt = code;
+ next = code->next;
+ }
+ if (next->op == EXEC_IF
+ && next->block
+ && next->block->op == EXEC_IF
+ && next->block->next->op == EXEC_ASSIGN)
+ {
+ comp_cond = next->block->expr1;
+ stmt = next->block->next;
+ if (stmt->next)
+ {
+ loc = &stmt->loc;
+ goto unexpected;
+ }
+ }
+ else if (capture_stmt)
+ {
+ gfc_error ("Expected IF at %L in atomic compare capture",
+ &next->loc);
+ return;
+ }
+ if (stmt && !capture_stmt && next->block->block)
+ {
+ if (next->block->block->expr1)
+ {
+ gfc_error ("Expected ELSE at %L in atomic compare capture",
+ &next->block->block->expr1->where);
+ return;
+ }
+ if (!code->block->block->next
+ || code->block->block->next->op != EXEC_ASSIGN)
+ {
+ loc = (code->block->block->next ? &code->block->block->next->loc
+ : &code->block->block->loc);
+ goto unexpected;
+ }
+ capture_stmt = code->block->block->next;
+ if (capture_stmt->next)
+ {
+ loc = &capture_stmt->next->loc;
+ goto unexpected;
+ }
+ }
+ if (stmt && !capture_stmt && next->next->op == EXEC_ASSIGN)
+ capture_stmt = next->next;
+ else if (!capture_stmt)
+ {
+ loc = &code->loc;
+ goto unexpected;
+ }
+ }
+ else if (atomic_code->ext.omp_clauses->compare)
+ {
+ /* Must be: "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
+ if (code->op == EXEC_IF
+ && code->block
+ && code->block->op == EXEC_IF
+ && code->block->next->op == EXEC_ASSIGN)
+ {
+ comp_cond = code->block->expr1;
+ stmt = code->block->next;
+ if (stmt->next || code->block->block)
+ {
+ loc = stmt->next ? &stmt->next->loc : &code->block->block->loc;
+ goto unexpected;
+ }
+ }
+ else
+ {
+ loc = &code->loc;
+ goto unexpected;
+ }
+ }
+ else if (atomic_code->ext.omp_clauses->capture)
+ {
+ /* Must be: "v = x" followed/preceded by "x = ...". */
+ if (code->op != EXEC_ASSIGN)
+ goto unexpected;
+ if (code->next->op != EXEC_ASSIGN)
+ {
+ loc = &code->next->loc;
+ goto unexpected;
+ }
+ gfc_expr *expr2, *expr2_next;
+ expr2 = is_conversion (code->expr2, true, true);
+ if (expr2 == NULL)
+ expr2 = code->expr2;
+ expr2_next = is_conversion (code->next->expr2, true, true);
+ if (expr2_next == NULL)
+ expr2_next = code->next->expr2;
+ if (code->expr1->expr_type == EXPR_VARIABLE
+ && code->next->expr1->expr_type == EXPR_VARIABLE
+ && expr2->expr_type == EXPR_VARIABLE
+ && expr2_next->expr_type == EXPR_VARIABLE)
+ {
+ if (code->expr1->symtree->n.sym == expr2_next->symtree->n.sym)
+ {
+ stmt = code;
+ capture_stmt = code->next;
+ }
+ else
+ {
+ capture_stmt = code;
+ stmt = code->next;
+ }
+ }
+ else if (expr2->expr_type == EXPR_VARIABLE)
+ {
+ capture_stmt = code;
+ stmt = code->next;
+ }
+ else
+ {
+ stmt = code;
+ capture_stmt = code->next;
+ }
+ gcc_assert (!code->next->next);
+ }
+ else
+ {
+ /* x = ... */
+ stmt = code;
+ if (!atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_ASSIGN)
+ goto unexpected;
+ gcc_assert (!code->next);
+ }
+
+ if (comp_cond)
+ {
+ if (comp_cond->expr_type != EXPR_OP
+ || (comp_cond->value.op.op != INTRINSIC_EQ
+ && comp_cond->value.op.op != INTRINSIC_EQ_OS
+ && comp_cond->value.op.op != INTRINSIC_EQV))
+ {
+ gfc_error ("Expected %<==%>, %<.EQ.%> or %<.EQV.%> atomic comparison "
+ "expression at %L", &comp_cond->where);
+ return;
+ }
+ if (!is_scalar_intrinsic_expr (comp_cond->value.op.op1, true, true))
+ {
+ gfc_error ("Expected scalar intrinsic variable at %L in atomic "
+ "comparison", &comp_cond->value.op.op1->where);
+ return;
+ }
+ if (!gfc_resolve_expr (comp_cond->value.op.op2))
+ return;
+ if (!is_scalar_intrinsic_expr (comp_cond->value.op.op2, false, false))
+ {
+ gfc_error ("Expected scalar intrinsic expression at %L in atomic "
+ "comparison", &comp_cond->value.op.op1->where);
+ return;
+ }
+ }
+
+ if (!is_scalar_intrinsic_expr (stmt->expr1, true, false))
+ {
+ gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
+ "intrinsic type at %L", &stmt->expr1->where);
+ return;
+ }
+
+ if (!gfc_resolve_expr (stmt->expr2))
+ return;
+ if (!is_scalar_intrinsic_expr (stmt->expr2, false, false))
+ {
+ gfc_error ("!$OMP ATOMIC statement must assign an expression of "
+ "intrinsic type at %L", &stmt->expr2->where);
+ return;
+ }
+
+ if (gfc_expr_attr (stmt->expr1).allocatable)
+ {
+ gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
+ &stmt->expr1->where);
+ return;
+ }
+
+ var = stmt->expr1->symtree->n.sym;
+ stmt_expr2 = is_conversion (stmt->expr2, true, true);
+ if (stmt_expr2 == NULL)
+ stmt_expr2 = stmt->expr2;
+
+ switch (aop)
+ {
+ case GFC_OMP_ATOMIC_READ:
+ if (stmt_expr2->expr_type != EXPR_VARIABLE)
+ gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
+ "variable of intrinsic type at %L", &stmt_expr2->where);
+ return;
+ case GFC_OMP_ATOMIC_WRITE:
+ if (expr_references_sym (stmt_expr2, var, NULL))
+ gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
+ "must be scalar and cannot reference var at %L",
+ &stmt_expr2->where);
+ return;
+ default:
+ break;
+ }
+
+ if (atomic_code->ext.omp_clauses->capture)
+ {
+ if (!is_scalar_intrinsic_expr (capture_stmt->expr1, true, false))
+ {
+ gfc_error ("!$OMP ATOMIC capture-statement must set a scalar "
+ "variable of intrinsic type at %L",
+ &capture_stmt->expr1->where);
+ return;
+ }
+
+ if (!is_scalar_intrinsic_expr (capture_stmt->expr2, true, true))
+ {
+ gfc_error ("!$OMP ATOMIC capture-statement requires a scalar variable"
+ " of intrinsic type at %L", &capture_stmt->expr2->where);
+ return;
+ }
+ capt_expr2 = is_conversion (capture_stmt->expr2, true, true);
+ if (capt_expr2 == NULL)
+ capt_expr2 = capture_stmt->expr2;
+
+ if (capt_expr2->symtree->n.sym != var)
+ {
+ gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
+ "different variable than update statement writes "
+ "into at %L", &capture_stmt->expr2->where);
+ return;
+ }
+ }
+
+ if (atomic_code->ext.omp_clauses->compare)
+ {
+ gfc_expr *var_expr;
+ if (comp_cond->value.op.op1->expr_type == EXPR_VARIABLE)
+ var_expr = comp_cond->value.op.op1;
+ else
+ var_expr = comp_cond->value.op.op1->value.function.actual->expr;
+ if (var_expr->symtree->n.sym != var)
+ {
+ gfc_error ("For !$OMP ATOMIC COMPARE, the first operand in comparison"
+ " at %L must be the variable %qs that the update statement"
+ " writes into at %L", &var_expr->where, var->name,
+ &stmt->expr1->where);
+ return;
+ }
+ if (stmt_expr2->rank != 0 || expr_references_sym (stmt_expr2, var, NULL))
+ {
+ gfc_error ("expr in !$OMP ATOMIC COMPARE assignment var = expr "
+ "must be scalar and cannot reference var at %L",
+ &stmt_expr2->where);
+ return;
+ }
+ }
+ else if (atomic_code->ext.omp_clauses->capture
+ && !expr_references_sym (stmt_expr2, var, NULL))
+ atomic_code->ext.omp_clauses->atomic_op
+ = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
+ | GFC_OMP_ATOMIC_SWAP);
+ else if (stmt_expr2->expr_type == EXPR_OP)
+ {
+ gfc_expr *v = NULL, *e, *c;
+ gfc_intrinsic_op op = stmt_expr2->value.op.op;
+ gfc_intrinsic_op alt_op = INTRINSIC_NONE;
+
+ if (atomic_code->ext.omp_clauses->fail != OMP_MEMORDER_UNSET)
+ gfc_error ("!$OMP ATOMIC UPDATE at %L with FAIL clause requiries either"
+ " the COMPARE clause or using the intrinsic MIN/MAX "
+ "procedure", &atomic_code->loc);
+ switch (op)
+ {
+ case INTRINSIC_PLUS:
+ alt_op = INTRINSIC_MINUS;
+ break;
+ case INTRINSIC_TIMES:
+ alt_op = INTRINSIC_DIVIDE;
+ break;
+ case INTRINSIC_MINUS:
+ alt_op = INTRINSIC_PLUS;
+ break;
+ case INTRINSIC_DIVIDE:
+ alt_op = INTRINSIC_TIMES;
+ break;
+ case INTRINSIC_AND:
+ case INTRINSIC_OR:
+ break;
+ case INTRINSIC_EQV:
+ alt_op = INTRINSIC_NEQV;
+ break;
+ case INTRINSIC_NEQV:
+ alt_op = INTRINSIC_EQV;
+ break;
+ default:
+ gfc_error ("!$OMP ATOMIC assignment operator must be binary "
+ "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
+ &stmt_expr2->where);
+ return;
+ }
+
+ /* Check for var = var op expr resp. var = expr op var where
+ expr doesn't reference var and var op expr is mathematically
+ equivalent to var op (expr) resp. expr op var equivalent to
+ (expr) op var. We rely here on the fact that the matcher
+ for x op1 y op2 z where op1 and op2 have equal precedence
+ returns (x op1 y) op2 z. */
+ e = stmt_expr2->value.op.op2;
+ if (e->expr_type == EXPR_VARIABLE
+ && e->symtree != NULL
+ && e->symtree->n.sym == var)
+ v = e;
+ else if ((c = is_conversion (e, false, true)) != NULL
+ && c->expr_type == EXPR_VARIABLE
+ && c->symtree != NULL
+ && c->symtree->n.sym == var)
+ v = c;
+ else
+ {
+ gfc_expr **p = NULL, **q;
+ for (q = &stmt_expr2->value.op.op1; (e = *q) != NULL; )
+ if (e->expr_type == EXPR_VARIABLE
+ && e->symtree != NULL
+ && e->symtree->n.sym == var)
+ {
+ v = e;
+ break;
+ }
+ else if ((c = is_conversion (e, false, true)) != NULL)
+ q = &e->value.function.actual->expr;
+ else if (e->expr_type != EXPR_OP
+ || (e->value.op.op != op
+ && e->value.op.op != alt_op)
+ || e->rank != 0)
+ break;
+ else
+ {
+ p = q;
+ q = &e->value.op.op1;
+ }
+
+ if (v == NULL)
+ {
+ gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
+ "or var = expr op var at %L", &stmt_expr2->where);
+ return;
+ }
+
+ if (p != NULL)
+ {
+ e = *p;
+ switch (e->value.op.op)
+ {
+ case INTRINSIC_MINUS:
+ case INTRINSIC_DIVIDE:
+ case INTRINSIC_EQV:
+ case INTRINSIC_NEQV:
+ gfc_error ("!$OMP ATOMIC var = var op expr not "
+ "mathematically equivalent to var = var op "
+ "(expr) at %L", &stmt_expr2->where);
+ break;
+ default:
+ break;
+ }
+
+ /* Canonicalize into var = var op (expr). */
+ *p = e->value.op.op2;
+ e->value.op.op2 = stmt_expr2;
+ e->ts = stmt_expr2->ts;
+ if (stmt->expr2 == stmt_expr2)
+ stmt->expr2 = stmt_expr2 = e;
+ else
+ stmt->expr2->value.function.actual->expr = stmt_expr2 = e;
+
+ if (!gfc_compare_types (&stmt_expr2->value.op.op1->ts,
+ &stmt_expr2->ts))
+ {
+ for (p = &stmt_expr2->value.op.op1; *p != v;
+ p = &(*p)->value.function.actual->expr)
+ ;
+ *p = NULL;
+ gfc_free_expr (stmt_expr2->value.op.op1);
+ stmt_expr2->value.op.op1 = v;
+ gfc_convert_type (v, &stmt_expr2->ts, 2);
+ }
+ }
+ }
+
+ if (e->rank != 0 || expr_references_sym (stmt->expr2, var, v))
+ {
+ gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
+ "must be scalar and cannot reference var at %L",
+ &stmt_expr2->where);
+ return;
+ }
+ }
+ else if (stmt_expr2->expr_type == EXPR_FUNCTION
+ && stmt_expr2->value.function.isym != NULL
+ && stmt_expr2->value.function.esym == NULL
+ && stmt_expr2->value.function.actual != NULL
+ && stmt_expr2->value.function.actual->next != NULL)
+ {
+ gfc_actual_arglist *arg, *var_arg;
+
+ switch (stmt_expr2->value.function.isym->id)
+ {
+ case GFC_ISYM_MIN:
+ case GFC_ISYM_MAX:
+ break;
+ case GFC_ISYM_IAND:
+ case GFC_ISYM_IOR:
+ case GFC_ISYM_IEOR:
+ if (stmt_expr2->value.function.actual->next->next != NULL)
+ {
+ gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
+ "or IEOR must have two arguments at %L",
+ &stmt_expr2->where);
+ return;
+ }
+ break;
+ default:
+ gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
+ "MIN, MAX, IAND, IOR or IEOR at %L",
+ &stmt_expr2->where);
+ return;
+ }
+
+ var_arg = NULL;
+ for (arg = stmt_expr2->value.function.actual; arg; arg = arg->next)
+ {
+ gfc_expr *e = NULL;
+ if (arg == stmt_expr2->value.function.actual
+ || (var_arg == NULL && arg->next == NULL))
+ {
+ e = is_conversion (arg->expr, false, true);
+ if (!e)
+ e = arg->expr;
+ if (e->expr_type == EXPR_VARIABLE
+ && e->symtree != NULL
+ && e->symtree->n.sym == var)
+ var_arg = arg;
+ }
+ if ((!var_arg || !e) && expr_references_sym (arg->expr, var, NULL))
+ {
+ gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
+ "not reference %qs at %L",
+ var->name, &arg->expr->where);
+ return;
+ }
+ if (arg->expr->rank != 0)
+ {
+ gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
+ "at %L", &arg->expr->where);
+ return;
+ }
+ }
+
+ if (var_arg == NULL)
+ {
+ gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
+ "be %qs at %L", var->name, &stmt_expr2->where);
+ return;
+ }
+
+ if (var_arg != stmt_expr2->value.function.actual)
+ {
+ /* Canonicalize, so that var comes first. */
+ gcc_assert (var_arg->next == NULL);
+ for (arg = stmt_expr2->value.function.actual;
+ arg->next != var_arg; arg = arg->next)
+ ;
+ var_arg->next = stmt_expr2->value.function.actual;
+ stmt_expr2->value.function.actual = var_arg;
+ arg->next = NULL;
+ }
+ }
+ else
+ gfc_error ("!$OMP ATOMIC assignment must have an operator or "
+ "intrinsic on right hand side at %L", &stmt_expr2->where);
+ return;
+
+unexpected:
+ gfc_error ("unexpected !$OMP ATOMIC expression at %L",
+ loc ? loc : &code->loc);
+ return;
+}
+
+
+static struct fortran_omp_context
+{
+ gfc_code *code;
+ hash_set<gfc_symbol *> *sharing_clauses;
+ hash_set<gfc_symbol *> *private_iterators;
+ struct fortran_omp_context *previous;
+ bool is_openmp;
+} *omp_current_ctx;
+static gfc_code *omp_current_do_code;
+static int omp_current_do_collapse;
+
+void
+gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
+{
+ if (code->block->next && code->block->next->op == EXEC_DO)
+ {
+ int i;
+ gfc_code *c;
+
+ omp_current_do_code = code->block->next;
+ if (code->ext.omp_clauses->orderedc)
+ omp_current_do_collapse = code->ext.omp_clauses->orderedc;
+ else
+ omp_current_do_collapse = code->ext.omp_clauses->collapse;
+ for (i = 1, c = omp_current_do_code; i < omp_current_do_collapse; i++)
+ {
+ c = c->block;
+ if (c->op != EXEC_DO || c->next == NULL)
+ break;
+ c = c->next;
+ if (c->op != EXEC_DO)
+ break;
+ }
+ if (i < omp_current_do_collapse || omp_current_do_collapse <= 0)
+ omp_current_do_collapse = 1;
+ if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
+ {
+ locus *loc
+ = &code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
+ if (code->ext.omp_clauses->ordered)
+ gfc_error ("ORDERED clause specified together with %<inscan%> "
+ "REDUCTION clause at %L", loc);
+ if (code->ext.omp_clauses->sched_kind != OMP_SCHED_NONE)
+ gfc_error ("SCHEDULE clause specified together with %<inscan%> "
+ "REDUCTION clause at %L", loc);
+ if (!c->block
+ || !c->block->next
+ || !c->block->next->next
+ || c->block->next->next->op != EXEC_OMP_SCAN
+ || !c->block->next->next->next
+ || c->block->next->next->next->next)
+ gfc_error ("With INSCAN at %L, expected loop body with !$OMP SCAN "
+ "between two structured-block-sequences", loc);
+ else
+ /* Mark as checked; flag will be unset later. */
+ c->block->next->next->ext.omp_clauses->if_present = true;
+ }
+ }
+ gfc_resolve_blocks (code->block, ns);
+ omp_current_do_collapse = 0;
+ omp_current_do_code = NULL;
+}
+
+
+void
+gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
+{
+ struct fortran_omp_context ctx;
+ gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
+ gfc_omp_namelist *n;
+ int list;
+
+ ctx.code = code;
+ ctx.sharing_clauses = new hash_set<gfc_symbol *>;
+ ctx.private_iterators = new hash_set<gfc_symbol *>;
+ ctx.previous = omp_current_ctx;
+ ctx.is_openmp = true;
+ omp_current_ctx = &ctx;
+
+ for (list = 0; list < OMP_LIST_NUM; list++)
+ switch (list)
+ {
+ case OMP_LIST_SHARED:
+ case OMP_LIST_PRIVATE:
+ case OMP_LIST_FIRSTPRIVATE:
+ case OMP_LIST_LASTPRIVATE:
+ case OMP_LIST_REDUCTION:
+ case OMP_LIST_REDUCTION_INSCAN:
+ case OMP_LIST_REDUCTION_TASK:
+ case OMP_LIST_IN_REDUCTION:
+ case OMP_LIST_TASK_REDUCTION:
+ case OMP_LIST_LINEAR:
+ for (n = omp_clauses->lists[list]; n; n = n->next)
+ ctx.sharing_clauses->add (n->sym);
+ break;
+ default:
+ break;
+ }
+
+ switch (code->op)
+ {
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_DO_SIMD:
+ case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
+ case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
+ case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
+ case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
+ case EXEC_OMP_MASKED_TASKLOOP:
+ case EXEC_OMP_MASKED_TASKLOOP_SIMD:
+ case EXEC_OMP_MASTER_TASKLOOP:
+ case EXEC_OMP_MASTER_TASKLOOP_SIMD:
+ case EXEC_OMP_TARGET_PARALLEL_DO:
+ case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
+ case EXEC_OMP_TASKLOOP:
+ case EXEC_OMP_TASKLOOP_SIMD:
+ case EXEC_OMP_TEAMS_DISTRIBUTE:
+ case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
+ gfc_resolve_omp_do_blocks (code, ns);
+ break;
+ default:
+ gfc_resolve_blocks (code->block, ns);
+ }
+
+ omp_current_ctx = ctx.previous;
+ delete ctx.sharing_clauses;
+ delete ctx.private_iterators;
+}
+
+
+/* Save and clear openmp.c private state. */
+
+void
+gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state)
+{
+ state->ptrs[0] = omp_current_ctx;
+ state->ptrs[1] = omp_current_do_code;
+ state->ints[0] = omp_current_do_collapse;
+ omp_current_ctx = NULL;
+ omp_current_do_code = NULL;
+ omp_current_do_collapse = 0;
+}
+
+
+/* Restore openmp.c private state from the saved state. */
+
+void
+gfc_omp_restore_state (struct gfc_omp_saved_state *state)
+{
+ omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0];
+ omp_current_do_code = (gfc_code *) state->ptrs[1];
+ omp_current_do_collapse = state->ints[0];
+}
+
+
+/* Note a DO iterator variable. This is special in !$omp parallel
+ construct, where they are predetermined private. */
+
+void
+gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause)
+{
+ if (omp_current_ctx == NULL)
+ return;
+
+ int i = omp_current_do_collapse;
+ gfc_code *c = omp_current_do_code;
+
+ if (sym->attr.threadprivate)
+ return;
+
+ /* !$omp do and !$omp parallel do iteration variable is predetermined
+ private just in the !$omp do resp. !$omp parallel do construct,
+ with no implications for the outer parallel constructs. */
+
+ while (i-- >= 1)
+ {
+ if (code == c)
+ return;
+
+ c = c->block->next;
+ }
+
+ /* An openacc context may represent a data clause. Abort if so. */
+ if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code))
+ return;
+
+ if (omp_current_ctx->sharing_clauses->contains (sym))
+ return;
+
+ if (! omp_current_ctx->private_iterators->add (sym) && add_clause)
+ {
+ gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
+ gfc_omp_namelist *p;
+
+ p = gfc_get_omp_namelist ();
+ p->sym = sym;
+ p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
+ omp_clauses->lists[OMP_LIST_PRIVATE] = p;
+ }
+}
+
+static void
+handle_local_var (gfc_symbol *sym)
+{
+ if (sym->attr.flavor != FL_VARIABLE
+ || sym->as != NULL
+ || (sym->ts.type != BT_INTEGER && sym->ts.type != BT_REAL))
+ return;
+ gfc_resolve_do_iterator (sym->ns->code, sym, false);
+}
+
+void
+gfc_resolve_omp_local_vars (gfc_namespace *ns)
+{
+ if (omp_current_ctx)
+ gfc_traverse_ns (ns, handle_local_var);
+}
+
+static void
+resolve_omp_do (gfc_code *code)
+{
+ gfc_code *do_code, *c;
+ int list, i, collapse;
+ gfc_omp_namelist *n;
+ gfc_symbol *dovar;
+ const char *name;
+ bool is_simd = false;
+
+ switch (code->op)
+ {
+ case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break;
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
+ name = "!$OMP DISTRIBUTE PARALLEL DO";
+ break;
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ name = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
+ is_simd = true;
+ break;
+ case EXEC_OMP_DISTRIBUTE_SIMD:
+ name = "!$OMP DISTRIBUTE SIMD";
+ is_simd = true;
+ break;
+ case EXEC_OMP_DO: name = "!$OMP DO"; break;
+ case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break;
+ case EXEC_OMP_LOOP: name = "!$OMP LOOP"; break;
+ case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break;
+ case EXEC_OMP_PARALLEL_DO_SIMD:
+ name = "!$OMP PARALLEL DO SIMD";
+ is_simd = true;
+ break;
+ case EXEC_OMP_PARALLEL_LOOP: name = "!$OMP PARALLEL LOOP"; break;
+ case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
+ name = "!$OMP PARALLEL MASKED TASKLOOP";
+ break;
+ case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
+ name = "!$OMP PARALLEL MASKED TASKLOOP SIMD";
+ is_simd = true;
+ break;
+ case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
+ name = "!$OMP PARALLEL MASTER TASKLOOP";
+ break;
+ case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
+ name = "!$OMP PARALLEL MASTER TASKLOOP SIMD";
+ is_simd = true;
+ break;
+ case EXEC_OMP_MASKED_TASKLOOP: name = "!$OMP MASKED TASKLOOP"; break;
+ case EXEC_OMP_MASKED_TASKLOOP_SIMD:
+ name = "!$OMP MASKED TASKLOOP SIMD";
+ is_simd = true;
+ break;
+ case EXEC_OMP_MASTER_TASKLOOP: name = "!$OMP MASTER TASKLOOP"; break;
+ case EXEC_OMP_MASTER_TASKLOOP_SIMD:
+ name = "!$OMP MASTER TASKLOOP SIMD";
+ is_simd = true;
+ break;
+ case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break;
+ case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break;
+ case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
+ name = "!$OMP TARGET PARALLEL DO SIMD";
+ is_simd = true;
+ break;
+ case EXEC_OMP_TARGET_PARALLEL_LOOP:
+ name = "!$OMP TARGET PARALLEL LOOP";
+ break;
+ case EXEC_OMP_TARGET_SIMD:
+ name = "!$OMP TARGET SIMD";
+ is_simd = true;
+ break;
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
+ name = "!$OMP TARGET TEAMS DISTRIBUTE";
+ break;
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
+ break;
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
+ is_simd = true;
+ break;
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
+ name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
+ is_simd = true;
+ break;
+ case EXEC_OMP_TARGET_TEAMS_LOOP: name = "!$OMP TARGET TEAMS LOOP"; break;
+ case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break;
+ case EXEC_OMP_TASKLOOP_SIMD:
+ name = "!$OMP TASKLOOP SIMD";
+ is_simd = true;
+ break;
+ case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE"; break;
+ case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
+ break;
+ case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
+ is_simd = true;
+ break;
+ case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
+ name = "!$OMP TEAMS DISTRIBUTE SIMD";
+ is_simd = true;
+ break;
+ case EXEC_OMP_TEAMS_LOOP: name = "!$OMP TEAMS LOOP"; break;
+ default: gcc_unreachable ();
+ }
+
+ if (code->ext.omp_clauses)
+ resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
+
+ do_code = code->block->next;
+ if (code->ext.omp_clauses->orderedc)
+ collapse = code->ext.omp_clauses->orderedc;
+ else
+ {
+ collapse = code->ext.omp_clauses->collapse;
+ if (collapse <= 0)
+ collapse = 1;
+ }
+ for (i = 1; i <= collapse; i++)
+ {
+ if (do_code->op == EXEC_DO_WHILE)
+ {
+ gfc_error ("%s cannot be a DO WHILE or DO without loop control "
+ "at %L", name, &do_code->loc);
+ break;
+ }
+ if (do_code->op == EXEC_DO_CONCURRENT)
+ {
+ gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name,
+ &do_code->loc);
+ break;
+ }
+ gcc_assert (do_code->op == EXEC_DO);
+ if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
+ gfc_error ("%s iteration variable must be of type integer at %L",
+ name, &do_code->loc);
+ dovar = do_code->ext.iterator->var->symtree->n.sym;
+ if (dovar->attr.threadprivate)
+ gfc_error ("%s iteration variable must not be THREADPRIVATE "
+ "at %L", name, &do_code->loc);
+ if (code->ext.omp_clauses)
+ for (list = 0; list < OMP_LIST_NUM; list++)
+ if (!is_simd || code->ext.omp_clauses->collapse > 1
+ ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
+ && list != OMP_LIST_ALLOCATE)
+ : (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
+ && list != OMP_LIST_ALLOCATE && list != OMP_LIST_LINEAR))
+ for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
+ if (dovar == n->sym)
+ {
+ if (!is_simd || code->ext.omp_clauses->collapse > 1)
+ gfc_error ("%s iteration variable present on clause "
+ "other than PRIVATE, LASTPRIVATE or "
+ "ALLOCATE at %L", name, &do_code->loc);
+ else
+ gfc_error ("%s iteration variable present on clause "
+ "other than PRIVATE, LASTPRIVATE, ALLOCATE or "
+ "LINEAR at %L", name, &do_code->loc);
+ break;
+ }
+ if (i > 1)
+ {
+ gfc_code *do_code2 = code->block->next;
+ int j;
+
+ for (j = 1; j < i; j++)
+ {
+ gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
+ if (dovar == ivar
+ || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
+ || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
+ || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
+ {
+ gfc_error ("%s collapsed loops don't form rectangular "
+ "iteration space at %L", name, &do_code->loc);
+ break;
+ }
+ do_code2 = do_code2->block->next;
+ }
+ }
+ for (c = do_code->next; c; c = c->next)
+ if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
+ {
+ gfc_error ("collapsed %s loops not perfectly nested at %L",
+ name, &c->loc);
+ break;
+ }
+ if (i == collapse || c)
+ break;
+ do_code = do_code->block;
+ if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
+ {
+ gfc_error ("not enough DO loops for collapsed %s at %L",
+ name, &code->loc);
+ break;
+ }
+ do_code = do_code->next;
+ if (do_code == NULL
+ || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE))
+ {
+ gfc_error ("not enough DO loops for collapsed %s at %L",
+ name, &code->loc);
+ break;
+ }
+ }
+}
+
+
+static gfc_statement
+omp_code_to_statement (gfc_code *code)
+{
+ switch (code->op)
+ {
+ case EXEC_OMP_PARALLEL:
+ return ST_OMP_PARALLEL;
+ case EXEC_OMP_PARALLEL_MASKED:
+ return ST_OMP_PARALLEL_MASKED;
+ case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
+ return ST_OMP_PARALLEL_MASKED_TASKLOOP;
+ case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
+ return ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD;
+ case EXEC_OMP_PARALLEL_MASTER:
+ return ST_OMP_PARALLEL_MASTER;
+ case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
+ return ST_OMP_PARALLEL_MASTER_TASKLOOP;
+ case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
+ return ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD;
+ case EXEC_OMP_PARALLEL_SECTIONS:
+ return ST_OMP_PARALLEL_SECTIONS;
+ case EXEC_OMP_SECTIONS:
+ return ST_OMP_SECTIONS;
+ case EXEC_OMP_ORDERED:
+ return ST_OMP_ORDERED;
+ case EXEC_OMP_CRITICAL:
+ return ST_OMP_CRITICAL;
+ case EXEC_OMP_MASKED:
+ return ST_OMP_MASKED;
+ case EXEC_OMP_MASKED_TASKLOOP:
+ return ST_OMP_MASKED_TASKLOOP;
+ case EXEC_OMP_MASKED_TASKLOOP_SIMD:
+ return ST_OMP_MASKED_TASKLOOP_SIMD;
+ case EXEC_OMP_MASTER:
+ return ST_OMP_MASTER;
+ case EXEC_OMP_MASTER_TASKLOOP:
+ return ST_OMP_MASTER_TASKLOOP;
+ case EXEC_OMP_MASTER_TASKLOOP_SIMD:
+ return ST_OMP_MASTER_TASKLOOP_SIMD;
+ case EXEC_OMP_SINGLE:
+ return ST_OMP_SINGLE;
+ case EXEC_OMP_TASK:
+ return ST_OMP_TASK;
+ case EXEC_OMP_WORKSHARE:
+ return ST_OMP_WORKSHARE;
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+ return ST_OMP_PARALLEL_WORKSHARE;
+ case EXEC_OMP_DO:
+ return ST_OMP_DO;
+ case EXEC_OMP_LOOP:
+ return ST_OMP_LOOP;
+ case EXEC_OMP_ATOMIC:
+ return ST_OMP_ATOMIC;
+ case EXEC_OMP_BARRIER:
+ return ST_OMP_BARRIER;
+ case EXEC_OMP_CANCEL:
+ return ST_OMP_CANCEL;
+ case EXEC_OMP_CANCELLATION_POINT:
+ return ST_OMP_CANCELLATION_POINT;
+ case EXEC_OMP_ERROR:
+ return ST_OMP_ERROR;
+ case EXEC_OMP_FLUSH:
+ return ST_OMP_FLUSH;
+ case EXEC_OMP_DISTRIBUTE:
+ return ST_OMP_DISTRIBUTE;
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
+ return ST_OMP_DISTRIBUTE_PARALLEL_DO;
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ return ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD;
+ case EXEC_OMP_DISTRIBUTE_SIMD:
+ return ST_OMP_DISTRIBUTE_SIMD;
+ case EXEC_OMP_DO_SIMD:
+ return ST_OMP_DO_SIMD;
+ case EXEC_OMP_SCAN:
+ return ST_OMP_SCAN;
+ case EXEC_OMP_SCOPE:
+ return ST_OMP_SCOPE;
+ case EXEC_OMP_SIMD:
+ return ST_OMP_SIMD;
+ case EXEC_OMP_TARGET:
+ return ST_OMP_TARGET;
+ case EXEC_OMP_TARGET_DATA:
+ return ST_OMP_TARGET_DATA;
+ case EXEC_OMP_TARGET_ENTER_DATA:
+ return ST_OMP_TARGET_ENTER_DATA;
+ case EXEC_OMP_TARGET_EXIT_DATA:
+ return ST_OMP_TARGET_EXIT_DATA;
+ case EXEC_OMP_TARGET_PARALLEL:
+ return ST_OMP_TARGET_PARALLEL;
+ case EXEC_OMP_TARGET_PARALLEL_DO:
+ return ST_OMP_TARGET_PARALLEL_DO;
+ case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
+ return ST_OMP_TARGET_PARALLEL_DO_SIMD;
+ case EXEC_OMP_TARGET_PARALLEL_LOOP:
+ return ST_OMP_TARGET_PARALLEL_LOOP;
+ case EXEC_OMP_TARGET_SIMD:
+ return ST_OMP_TARGET_SIMD;
+ case EXEC_OMP_TARGET_TEAMS:
+ return ST_OMP_TARGET_TEAMS;
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
+ return ST_OMP_TARGET_TEAMS_DISTRIBUTE;
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
+ return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD;
+ case EXEC_OMP_TARGET_TEAMS_LOOP:
+ return ST_OMP_TARGET_TEAMS_LOOP;
+ case EXEC_OMP_TARGET_UPDATE:
+ return ST_OMP_TARGET_UPDATE;
+ case EXEC_OMP_TASKGROUP:
+ return ST_OMP_TASKGROUP;
+ case EXEC_OMP_TASKLOOP:
+ return ST_OMP_TASKLOOP;
+ case EXEC_OMP_TASKLOOP_SIMD:
+ return ST_OMP_TASKLOOP_SIMD;
+ case EXEC_OMP_TASKWAIT:
+ return ST_OMP_TASKWAIT;
+ case EXEC_OMP_TASKYIELD:
+ return ST_OMP_TASKYIELD;
+ case EXEC_OMP_TEAMS:
+ return ST_OMP_TEAMS;
+ case EXEC_OMP_TEAMS_DISTRIBUTE:
+ return ST_OMP_TEAMS_DISTRIBUTE;
+ case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO;
+ case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
+ case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
+ return ST_OMP_TEAMS_DISTRIBUTE_SIMD;
+ case EXEC_OMP_TEAMS_LOOP:
+ return ST_OMP_TEAMS_LOOP;
+ case EXEC_OMP_PARALLEL_DO:
+ return ST_OMP_PARALLEL_DO;
+ case EXEC_OMP_PARALLEL_DO_SIMD:
+ return ST_OMP_PARALLEL_DO_SIMD;
+ case EXEC_OMP_PARALLEL_LOOP:
+ return ST_OMP_PARALLEL_LOOP;
+ case EXEC_OMP_DEPOBJ:
+ return ST_OMP_DEPOBJ;
+ default:
+ gcc_unreachable ();
+ }
+}
+
+static gfc_statement
+oacc_code_to_statement (gfc_code *code)
+{
+ switch (code->op)
+ {
+ case EXEC_OACC_PARALLEL:
+ return ST_OACC_PARALLEL;
+ case EXEC_OACC_KERNELS:
+ return ST_OACC_KERNELS;
+ case EXEC_OACC_SERIAL:
+ return ST_OACC_SERIAL;
+ case EXEC_OACC_DATA:
+ return ST_OACC_DATA;
+ case EXEC_OACC_HOST_DATA:
+ return ST_OACC_HOST_DATA;
+ case EXEC_OACC_PARALLEL_LOOP:
+ return ST_OACC_PARALLEL_LOOP;
+ case EXEC_OACC_KERNELS_LOOP:
+ return ST_OACC_KERNELS_LOOP;
+ case EXEC_OACC_SERIAL_LOOP:
+ return ST_OACC_SERIAL_LOOP;
+ case EXEC_OACC_LOOP:
+ return ST_OACC_LOOP;
+ case EXEC_OACC_ATOMIC:
+ return ST_OACC_ATOMIC;
+ case EXEC_OACC_ROUTINE:
+ return ST_OACC_ROUTINE;
+ case EXEC_OACC_UPDATE:
+ return ST_OACC_UPDATE;
+ case EXEC_OACC_WAIT:
+ return ST_OACC_WAIT;
+ case EXEC_OACC_CACHE:
+ return ST_OACC_CACHE;
+ case EXEC_OACC_ENTER_DATA:
+ return ST_OACC_ENTER_DATA;
+ case EXEC_OACC_EXIT_DATA:
+ return ST_OACC_EXIT_DATA;
+ case EXEC_OACC_DECLARE:
+ return ST_OACC_DECLARE;
+ default:
+ gcc_unreachable ();
+ }
+}
+
+static void
+resolve_oacc_directive_inside_omp_region (gfc_code *code)
+{
+ if (omp_current_ctx != NULL && omp_current_ctx->is_openmp)
+ {
+ gfc_statement st = omp_code_to_statement (omp_current_ctx->code);
+ gfc_statement oacc_st = oacc_code_to_statement (code);
+ gfc_error ("The %s directive cannot be specified within "
+ "a %s region at %L", gfc_ascii_statement (oacc_st),
+ gfc_ascii_statement (st), &code->loc);
+ }
+}
+
+static void
+resolve_omp_directive_inside_oacc_region (gfc_code *code)
+{
+ if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp)
+ {
+ gfc_statement st = oacc_code_to_statement (omp_current_ctx->code);
+ gfc_statement omp_st = omp_code_to_statement (code);
+ gfc_error ("The %s directive cannot be specified within "
+ "a %s region at %L", gfc_ascii_statement (omp_st),
+ gfc_ascii_statement (st), &code->loc);
+ }
+}
+
+
+static void
+resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse,
+ const char *clause)
+{
+ gfc_symbol *dovar;
+ gfc_code *c;
+ int i;
+
+ for (i = 1; i <= collapse; i++)
+ {
+ if (do_code->op == EXEC_DO_WHILE)
+ {
+ gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
+ "at %L", &do_code->loc);
+ break;
+ }
+ if (do_code->op == EXEC_DO_CONCURRENT)
+ {
+ gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L",
+ &do_code->loc);
+ break;
+ }
+ gcc_assert (do_code->op == EXEC_DO);
+ if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
+ gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
+ &do_code->loc);
+ dovar = do_code->ext.iterator->var->symtree->n.sym;
+ if (i > 1)
+ {
+ gfc_code *do_code2 = code->block->next;
+ int j;
+
+ for (j = 1; j < i; j++)
+ {
+ gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
+ if (dovar == ivar
+ || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
+ || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
+ || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
+ {
+ gfc_error ("!$ACC LOOP %s loops don't form rectangular "
+ "iteration space at %L", clause, &do_code->loc);
+ break;
+ }
+ do_code2 = do_code2->block->next;
+ }
+ }
+ if (i == collapse)
+ break;
+ for (c = do_code->next; c; c = c->next)
+ if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
+ {
+ gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
+ clause, &c->loc);
+ break;
+ }
+ if (c)
+ break;
+ do_code = do_code->block;
+ if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
+ && do_code->op != EXEC_DO_CONCURRENT)
+ {
+ gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
+ clause, &code->loc);
+ break;
+ }
+ do_code = do_code->next;
+ if (do_code == NULL
+ || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
+ && do_code->op != EXEC_DO_CONCURRENT))
+ {
+ gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
+ clause, &code->loc);
+ break;
+ }
+ }
+}
+
+
+static void
+resolve_oacc_loop_blocks (gfc_code *code)
+{
+ if (!oacc_is_loop (code))
+ return;
+
+ if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang
+ && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector)
+ gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
+ "vectors at the same time at %L", &code->loc);
+
+ if (code->ext.omp_clauses->tile_list)
+ {
+ gfc_expr_list *el;
+ for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
+ {
+ if (el->expr == NULL)
+ {
+ /* NULL expressions are used to represent '*' arguments.
+ Convert those to a 0 expressions. */
+ el->expr = gfc_get_constant_expr (BT_INTEGER,
+ gfc_default_integer_kind,
+ &code->loc);
+ mpz_set_si (el->expr->value.integer, 0);
+ }
+ else
+ {
+ resolve_positive_int_expr (el->expr, "TILE");
+ if (el->expr->expr_type != EXPR_CONSTANT)
+ gfc_error ("TILE requires constant expression at %L",
+ &code->loc);
+ }
+ }
+ }
+}
+
+
+void
+gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
+{
+ fortran_omp_context ctx;
+ gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
+ gfc_omp_namelist *n;
+ int list;
+
+ resolve_oacc_loop_blocks (code);
+
+ ctx.code = code;
+ ctx.sharing_clauses = new hash_set<gfc_symbol *>;
+ ctx.private_iterators = new hash_set<gfc_symbol *>;
+ ctx.previous = omp_current_ctx;
+ ctx.is_openmp = false;
+ omp_current_ctx = &ctx;
+
+ for (list = 0; list < OMP_LIST_NUM; list++)
+ switch (list)
+ {
+ case OMP_LIST_PRIVATE:
+ for (n = omp_clauses->lists[list]; n; n = n->next)
+ ctx.sharing_clauses->add (n->sym);
+ break;
+ default:
+ break;
+ }
+
+ gfc_resolve_blocks (code->block, ns);
+
+ omp_current_ctx = ctx.previous;
+ delete ctx.sharing_clauses;
+ delete ctx.private_iterators;
+}
+
+
+static void
+resolve_oacc_loop (gfc_code *code)
+{
+ gfc_code *do_code;
+ int collapse;
+
+ if (code->ext.omp_clauses)
+ resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
+
+ do_code = code->block->next;
+ collapse = code->ext.omp_clauses->collapse;
+
+ /* Both collapsed and tiled loops are lowered the same way, but are not
+ compatible. In gfc_trans_omp_do, the tile is prioritized. */
+ if (code->ext.omp_clauses->tile_list)
+ {
+ int num = 0;
+ gfc_expr_list *el;
+ for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
+ ++num;
+ resolve_oacc_nested_loops (code, code->block->next, num, "tiled");
+ return;
+ }
+
+ if (collapse <= 0)
+ collapse = 1;
+ resolve_oacc_nested_loops (code, do_code, collapse, "collapsed");
+}
+
+void
+gfc_resolve_oacc_declare (gfc_namespace *ns)
+{
+ int list;
+ gfc_omp_namelist *n;
+ gfc_oacc_declare *oc;
+
+ if (ns->oacc_declare == NULL)
+ return;
+
+ for (oc = ns->oacc_declare; oc; oc = oc->next)
+ {
+ for (list = 0; list < OMP_LIST_NUM; list++)
+ for (n = oc->clauses->lists[list]; n; n = n->next)
+ {
+ n->sym->mark = 0;
+ if (n->sym->attr.flavor != FL_VARIABLE
+ && (n->sym->attr.flavor != FL_PROCEDURE
+ || n->sym->result != n->sym))
+ {
+ gfc_error ("Object %qs is not a variable at %L",
+ n->sym->name, &oc->loc);
+ continue;
+ }
+
+ if (n->expr && n->expr->ref->type == REF_ARRAY)
+ {
+ gfc_error ("Array sections: %qs not allowed in"
+ " !$ACC DECLARE at %L", n->sym->name, &oc->loc);
+ continue;
+ }
+ }
+
+ for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next)
+ check_array_not_assumed (n->sym, oc->loc, "DEVICE_RESIDENT");
+ }
+
+ for (oc = ns->oacc_declare; oc; oc = oc->next)
+ {
+ for (list = 0; list < OMP_LIST_NUM; list++)
+ for (n = oc->clauses->lists[list]; n; n = n->next)
+ {
+ if (n->sym->mark)
+ {
+ gfc_error ("Symbol %qs present on multiple clauses at %L",
+ n->sym->name, &oc->loc);
+ continue;
+ }
+ else
+ n->sym->mark = 1;
+ }
+ }
+
+ for (oc = ns->oacc_declare; oc; oc = oc->next)
+ {
+ for (list = 0; list < OMP_LIST_NUM; list++)
+ for (n = oc->clauses->lists[list]; n; n = n->next)
+ n->sym->mark = 0;
+ }
+}
+
+
+void
+gfc_resolve_oacc_routines (gfc_namespace *ns)
+{
+ for (gfc_oacc_routine_name *orn = ns->oacc_routine_names;
+ orn;
+ orn = orn->next)
+ {
+ gfc_symbol *sym = orn->sym;
+ if (!sym->attr.external
+ && !sym->attr.function
+ && !sym->attr.subroutine)
+ {
+ gfc_error ("NAME %qs does not refer to a subroutine or function"
+ " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
+ continue;
+ }
+ if (!gfc_add_omp_declare_target (&sym->attr, sym->name, &orn->loc))
+ {
+ gfc_error ("NAME %qs invalid"
+ " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
+ continue;
+ }
+ }
+}
+
+
+void
+gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
+{
+ resolve_oacc_directive_inside_omp_region (code);
+
+ switch (code->op)
+ {
+ case EXEC_OACC_PARALLEL:
+ case EXEC_OACC_KERNELS:
+ case EXEC_OACC_SERIAL:
+ case EXEC_OACC_DATA:
+ case EXEC_OACC_HOST_DATA:
+ case EXEC_OACC_UPDATE:
+ case EXEC_OACC_ENTER_DATA:
+ case EXEC_OACC_EXIT_DATA:
+ case EXEC_OACC_WAIT:
+ case EXEC_OACC_CACHE:
+ resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
+ break;
+ case EXEC_OACC_PARALLEL_LOOP:
+ case EXEC_OACC_KERNELS_LOOP:
+ case EXEC_OACC_SERIAL_LOOP:
+ case EXEC_OACC_LOOP:
+ resolve_oacc_loop (code);
+ break;
+ case EXEC_OACC_ATOMIC:
+ resolve_omp_atomic (code);
+ break;
+ default:
+ break;
+ }
+}
+
+
+/* Resolve OpenMP directive clauses and check various requirements
+ of each directive. */
+
+void
+gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
+{
+ resolve_omp_directive_inside_oacc_region (code);
+
+ if (code->op != EXEC_OMP_ATOMIC)
+ gfc_maybe_initialize_eh ();
+
+ switch (code->op)
+ {
+ case EXEC_OMP_DISTRIBUTE:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case EXEC_OMP_DISTRIBUTE_SIMD:
+ case EXEC_OMP_DO:
+ case EXEC_OMP_DO_SIMD:
+ case EXEC_OMP_LOOP:
+ case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_DO_SIMD:
+ case EXEC_OMP_PARALLEL_LOOP:
+ case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
+ case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
+ case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
+ case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
+ case EXEC_OMP_MASKED_TASKLOOP:
+ case EXEC_OMP_MASKED_TASKLOOP_SIMD:
+ case EXEC_OMP_MASTER_TASKLOOP:
+ case EXEC_OMP_MASTER_TASKLOOP_SIMD:
+ case EXEC_OMP_SIMD:
+ case EXEC_OMP_TARGET_PARALLEL_DO:
+ case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
+ case EXEC_OMP_TARGET_PARALLEL_LOOP:
+ case EXEC_OMP_TARGET_SIMD:
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
+ case EXEC_OMP_TARGET_TEAMS_LOOP:
+ case EXEC_OMP_TASKLOOP:
+ case EXEC_OMP_TASKLOOP_SIMD:
+ case EXEC_OMP_TEAMS_DISTRIBUTE:
+ case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
+ case EXEC_OMP_TEAMS_LOOP:
+ resolve_omp_do (code);
+ break;
+ case EXEC_OMP_CANCEL:
+ case EXEC_OMP_ERROR:
+ case EXEC_OMP_MASKED:
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+ case EXEC_OMP_PARALLEL:
+ case EXEC_OMP_PARALLEL_MASKED:
+ case EXEC_OMP_PARALLEL_MASTER:
+ case EXEC_OMP_PARALLEL_SECTIONS:
+ case EXEC_OMP_SCOPE:
+ case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SINGLE:
+ case EXEC_OMP_TARGET:
+ case EXEC_OMP_TARGET_DATA:
+ case EXEC_OMP_TARGET_ENTER_DATA:
+ case EXEC_OMP_TARGET_EXIT_DATA:
+ case EXEC_OMP_TARGET_PARALLEL:
+ case EXEC_OMP_TARGET_TEAMS:
+ case EXEC_OMP_TASK:
+ case EXEC_OMP_TASKWAIT:
+ case EXEC_OMP_TEAMS:
+ case EXEC_OMP_WORKSHARE:
+ case EXEC_OMP_DEPOBJ:
+ if (code->ext.omp_clauses)
+ resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
+ break;
+ case EXEC_OMP_TARGET_UPDATE:
+ if (code->ext.omp_clauses)
+ resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
+ if (code->ext.omp_clauses == NULL
+ || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
+ && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
+ gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
+ "FROM clause", &code->loc);
+ break;
+ case EXEC_OMP_ATOMIC:
+ resolve_omp_clauses (code, code->block->ext.omp_clauses, NULL);
+ resolve_omp_atomic (code);
+ break;
+ case EXEC_OMP_CRITICAL:
+ resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
+ if (!code->ext.omp_clauses->critical_name
+ && code->ext.omp_clauses->hint
+ && code->ext.omp_clauses->hint->ts.type == BT_INTEGER
+ && code->ext.omp_clauses->hint->expr_type == EXPR_CONSTANT
+ && mpz_sgn (code->ext.omp_clauses->hint->value.integer) != 0)
+ gfc_error ("OMP CRITICAL at %L with HINT clause requires a NAME, "
+ "except when omp_sync_hint_none is used", &code->loc);
+ break;
+ case EXEC_OMP_SCAN:
+ /* Flag is only used to checking, hence, it is unset afterwards. */
+ if (!code->ext.omp_clauses->if_present)
+ gfc_error ("Unexpected !$OMP SCAN at %L outside loop construct with "
+ "%<inscan%> REDUCTION clause", &code->loc);
+ code->ext.omp_clauses->if_present = false;
+ resolve_omp_clauses (code, code->ext.omp_clauses, ns);
+ break;
+ default:
+ break;
+ }
+}
+
+/* Resolve !$omp declare simd constructs in NS. */
+
+void
+gfc_resolve_omp_declare_simd (gfc_namespace *ns)
+{
+ gfc_omp_declare_simd *ods;
+
+ for (ods = ns->omp_declare_simd; ods; ods = ods->next)
+ {
+ if (ods->proc_name != NULL
+ && ods->proc_name != ns->proc_name)
+ gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
+ "%qs at %L", ns->proc_name->name, &ods->where);
+ if (ods->clauses)
+ resolve_omp_clauses (NULL, ods->clauses, ns);
+ }
+}
+
+struct omp_udr_callback_data
+{
+ gfc_omp_udr *omp_udr;
+ bool is_initializer;
+};
+
+static int
+omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data)
+{
+ struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
+ if ((*e)->expr_type == EXPR_VARIABLE)
+ {
+ if (cd->is_initializer)
+ {
+ if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
+ && (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
+ gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
+ "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
+ &(*e)->where);
+ }
+ else
+ {
+ if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
+ && (*e)->symtree->n.sym != cd->omp_udr->omp_in)
+ gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
+ "combiner of !$OMP DECLARE REDUCTION at %L",
+ &(*e)->where);
+ }
+ }
+ return 0;
+}
+
+/* Resolve !$omp declare reduction constructs. */
+
+static void
+gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
+{
+ gfc_actual_arglist *a;
+ const char *predef_name = NULL;
+
+ switch (omp_udr->rop)
+ {
+ case OMP_REDUCTION_PLUS:
+ case OMP_REDUCTION_TIMES:
+ case OMP_REDUCTION_MINUS:
+ case OMP_REDUCTION_AND:
+ case OMP_REDUCTION_OR:
+ case OMP_REDUCTION_EQV:
+ case OMP_REDUCTION_NEQV:
+ case OMP_REDUCTION_MAX:
+ case OMP_REDUCTION_USER:
+ break;
+ default:
+ gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
+ omp_udr->name, &omp_udr->where);
+ return;
+ }
+
+ if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name,
+ &omp_udr->ts, &predef_name))
+ {
+ if (predef_name)
+ gfc_error_now ("Redefinition of predefined %s "
+ "!$OMP DECLARE REDUCTION at %L",
+ predef_name, &omp_udr->where);
+ else
+ gfc_error_now ("Redefinition of predefined "
+ "!$OMP DECLARE REDUCTION at %L", &omp_udr->where);
+ return;
+ }
+
+ if (omp_udr->ts.type == BT_CHARACTER
+ && omp_udr->ts.u.cl->length
+ && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+ {
+ gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not "
+ "constant at %L", omp_udr->name, &omp_udr->where);
+ return;
+ }
+
+ struct omp_udr_callback_data cd;
+ cd.omp_udr = omp_udr;
+ cd.is_initializer = false;
+ gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
+ omp_udr_callback, &cd);
+ if (omp_udr->combiner_ns->code->op == EXEC_CALL)
+ {
+ for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
+ if (a->expr == NULL)
+ break;
+ if (a)
+ gfc_error ("Subroutine call with alternate returns in combiner "
+ "of !$OMP DECLARE REDUCTION at %L",
+ &omp_udr->combiner_ns->code->loc);
+ }
+ if (omp_udr->initializer_ns)
+ {
+ cd.is_initializer = true;
+ gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
+ omp_udr_callback, &cd);
+ if (omp_udr->initializer_ns->code->op == EXEC_CALL)
+ {
+ for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
+ if (a->expr == NULL)
+ break;
+ if (a)
+ gfc_error ("Subroutine call with alternate returns in "
+ "INITIALIZER clause of !$OMP DECLARE REDUCTION "
+ "at %L", &omp_udr->initializer_ns->code->loc);
+ for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
+ if (a->expr
+ && a->expr->expr_type == EXPR_VARIABLE
+ && a->expr->symtree->n.sym == omp_udr->omp_priv
+ && a->expr->ref == NULL)
+ break;
+ if (a == NULL)
+ gfc_error ("One of actual subroutine arguments in INITIALIZER "
+ "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
+ "at %L", &omp_udr->initializer_ns->code->loc);
+ }
+ }
+ else if (omp_udr->ts.type == BT_DERIVED
+ && !gfc_has_default_initializer (omp_udr->ts.u.derived))
+ {
+ gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
+ "of derived type without default initializer at %L",
+ &omp_udr->where);
+ return;
+ }
+}
+
+void
+gfc_resolve_omp_udrs (gfc_symtree *st)
+{
+ gfc_omp_udr *omp_udr;
+
+ if (st == NULL)
+ return;
+ gfc_resolve_omp_udrs (st->left);
+ gfc_resolve_omp_udrs (st->right);
+ for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
+ gfc_resolve_omp_udr (omp_udr);
+}
generated by cgit v1.1 at 2025-04-27 15:51:28 +0000