aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/parse.c
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/parse.c
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/parse.c')
-rw-r--r--gcc/fortran/parse.c6987
1 files changed, 0 insertions, 6987 deletions
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
deleted file mode 100644
index c04ad77..0000000
--- a/gcc/fortran/parse.c
+++ /dev/null
@@ -1,6987 +0,0 @@
-/* Main parser.
- Copyright (C) 2000-2022 Free Software Foundation, Inc.
- Contributed by Andy Vaught
-
-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 "options.h"
-#include "gfortran.h"
-#include <setjmp.h>
-#include "match.h"
-#include "parse.h"
-#include "tree-core.h"
-#include "omp-general.h"
-
-/* Current statement label. Zero means no statement label. Because new_st
- can get wiped during statement matching, we have to keep it separate. */
-
-gfc_st_label *gfc_statement_label;
-
-static locus label_locus;
-static jmp_buf eof_buf;
-
-gfc_state_data *gfc_state_stack;
-static bool last_was_use_stmt = false;
-
-/* TODO: Re-order functions to kill these forward decls. */
-static void check_statement_label (gfc_statement);
-static void undo_new_statement (void);
-static void reject_statement (void);
-
-
-/* A sort of half-matching function. We try to match the word on the
- input with the passed string. If this succeeds, we call the
- keyword-dependent matching function that will match the rest of the
- statement. For single keywords, the matching subroutine is
- gfc_match_eos(). */
-
-static match
-match_word (const char *str, match (*subr) (void), locus *old_locus)
-{
- match m;
-
- if (str != NULL)
- {
- m = gfc_match (str);
- if (m != MATCH_YES)
- return m;
- }
-
- m = (*subr) ();
-
- if (m != MATCH_YES)
- {
- gfc_current_locus = *old_locus;
- reject_statement ();
- }
-
- return m;
-}
-
-
-/* Like match_word, but if str is matched, set a flag that it
- was matched. */
-static match
-match_word_omp_simd (const char *str, match (*subr) (void), locus *old_locus,
- bool *simd_matched)
-{
- match m;
-
- if (str != NULL)
- {
- m = gfc_match (str);
- if (m != MATCH_YES)
- return m;
- *simd_matched = true;
- }
-
- m = (*subr) ();
-
- if (m != MATCH_YES)
- {
- gfc_current_locus = *old_locus;
- reject_statement ();
- }
-
- return m;
-}
-
-
-/* Load symbols from all USE statements encountered in this scoping unit. */
-
-static void
-use_modules (void)
-{
- gfc_error_buffer old_error;
-
- gfc_push_error (&old_error);
- gfc_buffer_error (false);
- gfc_use_modules ();
- gfc_buffer_error (true);
- gfc_pop_error (&old_error);
- gfc_commit_symbols ();
- gfc_warning_check ();
- gfc_current_ns->old_equiv = gfc_current_ns->equiv;
- gfc_current_ns->old_data = gfc_current_ns->data;
- last_was_use_stmt = false;
-}
-
-
-/* Figure out what the next statement is, (mostly) regardless of
- proper ordering. The do...while(0) is there to prevent if/else
- ambiguity. */
-
-#define match(keyword, subr, st) \
- do { \
- if (match_word (keyword, subr, &old_locus) == MATCH_YES) \
- return st; \
- else \
- undo_new_statement (); \
- } while (0)
-
-
-/* This is a specialist version of decode_statement that is used
- for the specification statements in a function, whose
- characteristics are deferred into the specification statements.
- eg.: INTEGER (king = mykind) foo ()
- USE mymodule, ONLY mykind.....
- The KIND parameter needs a return after USE or IMPORT, whereas
- derived type declarations can occur anywhere, up the executable
- block. ST_GET_FCN_CHARACTERISTICS is returned when we have run
- out of the correct kind of specification statements. */
-static gfc_statement
-decode_specification_statement (void)
-{
- gfc_statement st;
- locus old_locus;
- char c;
-
- if (gfc_match_eos () == MATCH_YES)
- return ST_NONE;
-
- old_locus = gfc_current_locus;
-
- if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES)
- {
- last_was_use_stmt = true;
- return ST_USE;
- }
- else
- {
- undo_new_statement ();
- if (last_was_use_stmt)
- use_modules ();
- }
-
- match ("import", gfc_match_import, ST_IMPORT);
-
- if (gfc_current_block ()->result->ts.type != BT_DERIVED)
- goto end_of_block;
-
- match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
- match (NULL, gfc_match_data_decl, ST_DATA_DECL);
- match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
-
- /* General statement matching: Instead of testing every possible
- statement, we eliminate most possibilities by peeking at the
- first character. */
-
- c = gfc_peek_ascii_char ();
-
- switch (c)
- {
- case 'a':
- match ("abstract% interface", gfc_match_abstract_interface,
- ST_INTERFACE);
- match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
- match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
- match ("automatic", gfc_match_automatic, ST_ATTR_DECL);
- break;
-
- case 'b':
- match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
- break;
-
- case 'c':
- match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
- match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
- break;
-
- case 'd':
- match ("data", gfc_match_data, ST_DATA);
- match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
- break;
-
- case 'e':
- match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
- match ("entry% ", gfc_match_entry, ST_ENTRY);
- match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
- match ("external", gfc_match_external, ST_ATTR_DECL);
- break;
-
- case 'f':
- match ("format", gfc_match_format, ST_FORMAT);
- break;
-
- case 'g':
- break;
-
- case 'i':
- match ("implicit", gfc_match_implicit, ST_IMPLICIT);
- match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
- match ("interface", gfc_match_interface, ST_INTERFACE);
- match ("intent", gfc_match_intent, ST_ATTR_DECL);
- match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
- break;
-
- case 'm':
- break;
-
- case 'n':
- match ("namelist", gfc_match_namelist, ST_NAMELIST);
- break;
-
- case 'o':
- match ("optional", gfc_match_optional, ST_ATTR_DECL);
- break;
-
- case 'p':
- match ("parameter", gfc_match_parameter, ST_PARAMETER);
- match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
- if (gfc_match_private (&st) == MATCH_YES)
- return st;
- match ("procedure", gfc_match_procedure, ST_PROCEDURE);
- if (gfc_match_public (&st) == MATCH_YES)
- return st;
- match ("protected", gfc_match_protected, ST_ATTR_DECL);
- break;
-
- case 'r':
- break;
-
- case 's':
- match ("save", gfc_match_save, ST_ATTR_DECL);
- match ("static", gfc_match_static, ST_ATTR_DECL);
- match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL);
- break;
-
- case 't':
- match ("target", gfc_match_target, ST_ATTR_DECL);
- match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
- break;
-
- case 'u':
- break;
-
- case 'v':
- match ("value", gfc_match_value, ST_ATTR_DECL);
- match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
- break;
-
- case 'w':
- break;
- }
-
- /* This is not a specification statement. See if any of the matchers
- has stored an error message of some sort. */
-
-end_of_block:
- gfc_clear_error ();
- gfc_buffer_error (false);
- gfc_current_locus = old_locus;
-
- return ST_GET_FCN_CHARACTERISTICS;
-}
-
-static bool in_specification_block;
-
-/* This is the primary 'decode_statement'. */
-static gfc_statement
-decode_statement (void)
-{
- gfc_statement st;
- locus old_locus;
- match m = MATCH_NO;
- char c;
-
- gfc_enforce_clean_symbol_state ();
-
- gfc_clear_error (); /* Clear any pending errors. */
- gfc_clear_warning (); /* Clear any pending warnings. */
-
- gfc_matching_function = false;
-
- if (gfc_match_eos () == MATCH_YES)
- return ST_NONE;
-
- if (gfc_current_state () == COMP_FUNCTION
- && gfc_current_block ()->result->ts.kind == -1)
- return decode_specification_statement ();
-
- old_locus = gfc_current_locus;
-
- c = gfc_peek_ascii_char ();
-
- if (c == 'u')
- {
- if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES)
- {
- last_was_use_stmt = true;
- return ST_USE;
- }
- else
- undo_new_statement ();
- }
-
- if (last_was_use_stmt)
- use_modules ();
-
- /* Try matching a data declaration or function declaration. The
- input "REALFUNCTIONA(N)" can mean several things in different
- contexts, so it (and its relatives) get special treatment. */
-
- if (gfc_current_state () == COMP_NONE
- || gfc_current_state () == COMP_INTERFACE
- || gfc_current_state () == COMP_CONTAINS)
- {
- gfc_matching_function = true;
- m = gfc_match_function_decl ();
- if (m == MATCH_YES)
- return ST_FUNCTION;
- else if (m == MATCH_ERROR)
- reject_statement ();
- else
- gfc_undo_symbols ();
- gfc_current_locus = old_locus;
- }
- gfc_matching_function = false;
-
- /* Legacy parameter statements are ambiguous with assignments so try parameter
- first. */
- match ("parameter", gfc_match_parameter, ST_PARAMETER);
-
- /* Match statements whose error messages are meant to be overwritten
- by something better. */
-
- match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
- match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
-
- if (in_specification_block)
- {
- m = match_word (NULL, gfc_match_st_function, &old_locus);
- if (m == MATCH_YES)
- return ST_STATEMENT_FUNCTION;
- }
-
- if (!(in_specification_block && m == MATCH_ERROR))
- {
- match (NULL, gfc_match_ptr_fcn_assign, ST_ASSIGNMENT);
- }
-
- match (NULL, gfc_match_data_decl, ST_DATA_DECL);
- match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
-
- /* Try to match a subroutine statement, which has the same optional
- prefixes that functions can have. */
-
- if (gfc_match_subroutine () == MATCH_YES)
- return ST_SUBROUTINE;
- gfc_undo_symbols ();
- gfc_current_locus = old_locus;
-
- if (gfc_match_submod_proc () == MATCH_YES)
- {
- if (gfc_new_block->attr.subroutine)
- return ST_SUBROUTINE;
- else if (gfc_new_block->attr.function)
- return ST_FUNCTION;
- }
- gfc_undo_symbols ();
- gfc_current_locus = old_locus;
-
- /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE
- statements, which might begin with a block label. The match functions for
- these statements are unusual in that their keyword is not seen before
- the matcher is called. */
-
- if (gfc_match_if (&st) == MATCH_YES)
- return st;
- gfc_undo_symbols ();
- gfc_current_locus = old_locus;
-
- if (gfc_match_where (&st) == MATCH_YES)
- return st;
- gfc_undo_symbols ();
- gfc_current_locus = old_locus;
-
- if (gfc_match_forall (&st) == MATCH_YES)
- return st;
- gfc_undo_symbols ();
- gfc_current_locus = old_locus;
-
- /* Try to match TYPE as an alias for PRINT. */
- if (gfc_match_type (&st) == MATCH_YES)
- return st;
- gfc_undo_symbols ();
- gfc_current_locus = old_locus;
-
- match (NULL, gfc_match_do, ST_DO);
- match (NULL, gfc_match_block, ST_BLOCK);
- match (NULL, gfc_match_associate, ST_ASSOCIATE);
- match (NULL, gfc_match_critical, ST_CRITICAL);
- match (NULL, gfc_match_select, ST_SELECT_CASE);
- match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
- match (NULL, gfc_match_select_rank, ST_SELECT_RANK);
-
- /* General statement matching: Instead of testing every possible
- statement, we eliminate most possibilities by peeking at the
- first character. */
-
- switch (c)
- {
- case 'a':
- match ("abstract% interface", gfc_match_abstract_interface,
- ST_INTERFACE);
- match ("allocate", gfc_match_allocate, ST_ALLOCATE);
- match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
- match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT);
- match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
- match ("automatic", gfc_match_automatic, ST_ATTR_DECL);
- break;
-
- case 'b':
- match ("backspace", gfc_match_backspace, ST_BACKSPACE);
- match ("block data", gfc_match_block_data, ST_BLOCK_DATA);
- match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
- break;
-
- case 'c':
- match ("call", gfc_match_call, ST_CALL);
- match ("change team", gfc_match_change_team, ST_CHANGE_TEAM);
- match ("close", gfc_match_close, ST_CLOSE);
- match ("continue", gfc_match_continue, ST_CONTINUE);
- match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
- match ("cycle", gfc_match_cycle, ST_CYCLE);
- match ("case", gfc_match_case, ST_CASE);
- match ("common", gfc_match_common, ST_COMMON);
- match ("contains", gfc_match_eos, ST_CONTAINS);
- match ("class", gfc_match_class_is, ST_CLASS_IS);
- match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
- break;
-
- case 'd':
- match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE);
- match ("data", gfc_match_data, ST_DATA);
- match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
- break;
-
- case 'e':
- match ("end file", gfc_match_endfile, ST_END_FILE);
- match ("end team", gfc_match_end_team, ST_END_TEAM);
- match ("exit", gfc_match_exit, ST_EXIT);
- match ("else", gfc_match_else, ST_ELSE);
- match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
- match ("else if", gfc_match_elseif, ST_ELSEIF);
- match ("error stop", gfc_match_error_stop, ST_ERROR_STOP);
- match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
-
- if (gfc_match_end (&st) == MATCH_YES)
- return st;
-
- match ("entry% ", gfc_match_entry, ST_ENTRY);
- match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
- match ("external", gfc_match_external, ST_ATTR_DECL);
- match ("event post", gfc_match_event_post, ST_EVENT_POST);
- match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT);
- break;
-
- case 'f':
- match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE);
- match ("final", gfc_match_final_decl, ST_FINAL);
- match ("flush", gfc_match_flush, ST_FLUSH);
- match ("form team", gfc_match_form_team, ST_FORM_TEAM);
- match ("format", gfc_match_format, ST_FORMAT);
- break;
-
- case 'g':
- match ("generic", gfc_match_generic, ST_GENERIC);
- match ("go to", gfc_match_goto, ST_GOTO);
- break;
-
- case 'i':
- match ("inquire", gfc_match_inquire, ST_INQUIRE);
- match ("implicit", gfc_match_implicit, ST_IMPLICIT);
- match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
- match ("import", gfc_match_import, ST_IMPORT);
- match ("interface", gfc_match_interface, ST_INTERFACE);
- match ("intent", gfc_match_intent, ST_ATTR_DECL);
- match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
- break;
-
- case 'l':
- match ("lock", gfc_match_lock, ST_LOCK);
- break;
-
- case 'm':
- match ("map", gfc_match_map, ST_MAP);
- match ("module% procedure", gfc_match_modproc, ST_MODULE_PROC);
- match ("module", gfc_match_module, ST_MODULE);
- break;
-
- case 'n':
- match ("nullify", gfc_match_nullify, ST_NULLIFY);
- match ("namelist", gfc_match_namelist, ST_NAMELIST);
- break;
-
- case 'o':
- match ("open", gfc_match_open, ST_OPEN);
- match ("optional", gfc_match_optional, ST_ATTR_DECL);
- break;
-
- case 'p':
- match ("print", gfc_match_print, ST_WRITE);
- match ("pause", gfc_match_pause, ST_PAUSE);
- match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
- if (gfc_match_private (&st) == MATCH_YES)
- return st;
- match ("procedure", gfc_match_procedure, ST_PROCEDURE);
- match ("program", gfc_match_program, ST_PROGRAM);
- if (gfc_match_public (&st) == MATCH_YES)
- return st;
- match ("protected", gfc_match_protected, ST_ATTR_DECL);
- break;
-
- case 'r':
- match ("rank", gfc_match_rank_is, ST_RANK);
- match ("read", gfc_match_read, ST_READ);
- match ("return", gfc_match_return, ST_RETURN);
- match ("rewind", gfc_match_rewind, ST_REWIND);
- break;
-
- case 's':
- match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL);
- match ("sequence", gfc_match_eos, ST_SEQUENCE);
- match ("stop", gfc_match_stop, ST_STOP);
- match ("save", gfc_match_save, ST_ATTR_DECL);
- match ("static", gfc_match_static, ST_ATTR_DECL);
- match ("submodule", gfc_match_submodule, ST_SUBMODULE);
- match ("sync all", gfc_match_sync_all, ST_SYNC_ALL);
- match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
- match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
- match ("sync team", gfc_match_sync_team, ST_SYNC_TEAM);
- break;
-
- case 't':
- match ("target", gfc_match_target, ST_ATTR_DECL);
- match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
- match ("type is", gfc_match_type_is, ST_TYPE_IS);
- break;
-
- case 'u':
- match ("union", gfc_match_union, ST_UNION);
- match ("unlock", gfc_match_unlock, ST_UNLOCK);
- break;
-
- case 'v':
- match ("value", gfc_match_value, ST_ATTR_DECL);
- match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
- break;
-
- case 'w':
- match ("wait", gfc_match_wait, ST_WAIT);
- match ("write", gfc_match_write, ST_WRITE);
- break;
- }
-
- /* All else has failed, so give up. See if any of the matchers has
- stored an error message of some sort. Suppress the "Unclassifiable
- statement" if a previous error message was emitted, e.g., by
- gfc_error_now (). */
- if (!gfc_error_check ())
- {
- int ecnt;
- gfc_get_errors (NULL, &ecnt);
- if (ecnt <= 0)
- gfc_error_now ("Unclassifiable statement at %C");
- }
-
- reject_statement ();
-
- gfc_error_recovery ();
-
- return ST_NONE;
-}
-
-/* Like match and if spec_only, goto do_spec_only without actually
- matching. */
-/* If the directive matched but the clauses failed, do not start
- matching the next directive in the same switch statement. */
-#define matcha(keyword, subr, st) \
- do { \
- match m2; \
- if (spec_only && gfc_match (keyword) == MATCH_YES) \
- goto do_spec_only; \
- else if ((m2 = match_word (keyword, subr, &old_locus)) \
- == MATCH_YES) \
- return st; \
- else if (m2 == MATCH_ERROR) \
- goto error_handling; \
- else \
- undo_new_statement (); \
- } while (0)
-
-static gfc_statement
-decode_oacc_directive (void)
-{
- locus old_locus;
- char c;
- bool spec_only = false;
-
- gfc_enforce_clean_symbol_state ();
-
- gfc_clear_error (); /* Clear any pending errors. */
- gfc_clear_warning (); /* Clear any pending warnings. */
-
- gfc_matching_function = false;
-
- if (gfc_current_state () == COMP_FUNCTION
- && gfc_current_block ()->result->ts.kind == -1)
- spec_only = true;
-
- old_locus = gfc_current_locus;
-
- /* General OpenACC directive matching: Instead of testing every possible
- statement, we eliminate most possibilities by peeking at the
- first character. */
-
- c = gfc_peek_ascii_char ();
-
- switch (c)
- {
- case 'r':
- matcha ("routine", gfc_match_oacc_routine, ST_OACC_ROUTINE);
- break;
- }
-
- gfc_unset_implicit_pure (NULL);
- if (gfc_pure (NULL))
- {
- gfc_error_now ("OpenACC directives other than ROUTINE may not appear in PURE "
- "procedures at %C");
- goto error_handling;
- }
-
- switch (c)
- {
- case 'a':
- matcha ("atomic", gfc_match_oacc_atomic, ST_OACC_ATOMIC);
- break;
- case 'c':
- matcha ("cache", gfc_match_oacc_cache, ST_OACC_CACHE);
- break;
- case 'd':
- matcha ("data", gfc_match_oacc_data, ST_OACC_DATA);
- match ("declare", gfc_match_oacc_declare, ST_OACC_DECLARE);
- break;
- case 'e':
- matcha ("end atomic", gfc_match_omp_eos_error, ST_OACC_END_ATOMIC);
- matcha ("end data", gfc_match_omp_eos_error, ST_OACC_END_DATA);
- matcha ("end host_data", gfc_match_omp_eos_error, ST_OACC_END_HOST_DATA);
- matcha ("end kernels loop", gfc_match_omp_eos_error, ST_OACC_END_KERNELS_LOOP);
- matcha ("end kernels", gfc_match_omp_eos_error, ST_OACC_END_KERNELS);
- matcha ("end loop", gfc_match_omp_eos_error, ST_OACC_END_LOOP);
- matcha ("end parallel loop", gfc_match_omp_eos_error,
- ST_OACC_END_PARALLEL_LOOP);
- matcha ("end parallel", gfc_match_omp_eos_error, ST_OACC_END_PARALLEL);
- matcha ("end serial loop", gfc_match_omp_eos_error,
- ST_OACC_END_SERIAL_LOOP);
- matcha ("end serial", gfc_match_omp_eos_error, ST_OACC_END_SERIAL);
- matcha ("enter data", gfc_match_oacc_enter_data, ST_OACC_ENTER_DATA);
- matcha ("exit data", gfc_match_oacc_exit_data, ST_OACC_EXIT_DATA);
- break;
- case 'h':
- matcha ("host_data", gfc_match_oacc_host_data, ST_OACC_HOST_DATA);
- break;
- case 'p':
- matcha ("parallel loop", gfc_match_oacc_parallel_loop,
- ST_OACC_PARALLEL_LOOP);
- matcha ("parallel", gfc_match_oacc_parallel, ST_OACC_PARALLEL);
- break;
- case 'k':
- matcha ("kernels loop", gfc_match_oacc_kernels_loop,
- ST_OACC_KERNELS_LOOP);
- matcha ("kernels", gfc_match_oacc_kernels, ST_OACC_KERNELS);
- break;
- case 'l':
- matcha ("loop", gfc_match_oacc_loop, ST_OACC_LOOP);
- break;
- case 's':
- matcha ("serial loop", gfc_match_oacc_serial_loop, ST_OACC_SERIAL_LOOP);
- matcha ("serial", gfc_match_oacc_serial, ST_OACC_SERIAL);
- break;
- case 'u':
- matcha ("update", gfc_match_oacc_update, ST_OACC_UPDATE);
- break;
- case 'w':
- matcha ("wait", gfc_match_oacc_wait, ST_OACC_WAIT);
- break;
- }
-
- /* Directive not found or stored an error message.
- Check and give up. */
-
- error_handling:
- if (gfc_error_check () == 0)
- gfc_error_now ("Unclassifiable OpenACC directive at %C");
-
- reject_statement ();
-
- gfc_error_recovery ();
-
- return ST_NONE;
-
- do_spec_only:
- reject_statement ();
- gfc_clear_error ();
- gfc_buffer_error (false);
- gfc_current_locus = old_locus;
- return ST_GET_FCN_CHARACTERISTICS;
-}
-
-/* Like match, but set a flag simd_matched if keyword matched
- and if spec_only, goto do_spec_only without actually matching. */
-#define matchs(keyword, subr, st) \
- do { \
- match m2; \
- if (spec_only && gfc_match (keyword) == MATCH_YES) \
- goto do_spec_only; \
- if ((m2 = match_word_omp_simd (keyword, subr, &old_locus, \
- &simd_matched)) == MATCH_YES) \
- { \
- ret = st; \
- goto finish; \
- } \
- else if (m2 == MATCH_ERROR) \
- goto error_handling; \
- else \
- undo_new_statement (); \
- } while (0)
-
-/* Like match, but don't match anything if not -fopenmp
- and if spec_only, goto do_spec_only without actually matching. */
-/* If the directive matched but the clauses failed, do not start
- matching the next directive in the same switch statement. */
-#define matcho(keyword, subr, st) \
- do { \
- match m2; \
- if (!flag_openmp) \
- ; \
- else if (spec_only && gfc_match (keyword) == MATCH_YES) \
- goto do_spec_only; \
- else if ((m2 = match_word (keyword, subr, &old_locus)) \
- == MATCH_YES) \
- { \
- ret = st; \
- goto finish; \
- } \
- else if (m2 == MATCH_ERROR) \
- goto error_handling; \
- else \
- undo_new_statement (); \
- } while (0)
-
-/* Like match, but set a flag simd_matched if keyword matched. */
-#define matchds(keyword, subr, st) \
- do { \
- match m2; \
- if ((m2 = match_word_omp_simd (keyword, subr, &old_locus, \
- &simd_matched)) == MATCH_YES) \
- { \
- ret = st; \
- goto finish; \
- } \
- else if (m2 == MATCH_ERROR) \
- goto error_handling; \
- else \
- undo_new_statement (); \
- } while (0)
-
-/* Like match, but don't match anything if not -fopenmp. */
-#define matchdo(keyword, subr, st) \
- do { \
- match m2; \
- if (!flag_openmp) \
- ; \
- else if ((m2 = match_word (keyword, subr, &old_locus)) \
- == MATCH_YES) \
- { \
- ret = st; \
- goto finish; \
- } \
- else if (m2 == MATCH_ERROR) \
- goto error_handling; \
- else \
- undo_new_statement (); \
- } while (0)
-
-static gfc_statement
-decode_omp_directive (void)
-{
- locus old_locus;
- char c;
- bool simd_matched = false;
- bool spec_only = false;
- gfc_statement ret = ST_NONE;
- bool pure_ok = true;
-
- gfc_enforce_clean_symbol_state ();
-
- gfc_clear_error (); /* Clear any pending errors. */
- gfc_clear_warning (); /* Clear any pending warnings. */
-
- gfc_matching_function = false;
-
- if (gfc_current_state () == COMP_FUNCTION
- && gfc_current_block ()->result->ts.kind == -1)
- spec_only = true;
-
- old_locus = gfc_current_locus;
-
- /* General OpenMP directive matching: Instead of testing every possible
- statement, we eliminate most possibilities by peeking at the
- first character. */
-
- c = gfc_peek_ascii_char ();
-
- /* match is for directives that should be recognized only if
- -fopenmp, matchs for directives that should be recognized
- if either -fopenmp or -fopenmp-simd.
- Handle only the directives allowed in PURE procedures
- first (those also shall not turn off implicit pure). */
- switch (c)
- {
- case 'd':
- matchds ("declare simd", gfc_match_omp_declare_simd,
- ST_OMP_DECLARE_SIMD);
- matchdo ("declare target", gfc_match_omp_declare_target,
- ST_OMP_DECLARE_TARGET);
- matchdo ("declare variant", gfc_match_omp_declare_variant,
- ST_OMP_DECLARE_VARIANT);
- break;
- case 's':
- matchs ("simd", gfc_match_omp_simd, ST_OMP_SIMD);
- break;
- }
-
- pure_ok = false;
- if (flag_openmp && gfc_pure (NULL))
- {
- gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET "
- "at %C may not appear in PURE procedures");
- gfc_error_recovery ();
- return ST_NONE;
- }
-
- /* match is for directives that should be recognized only if
- -fopenmp, matchs for directives that should be recognized
- if either -fopenmp or -fopenmp-simd. */
- switch (c)
- {
- case 'a':
- matcho ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
- break;
- case 'b':
- matcho ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
- break;
- case 'c':
- matcho ("cancellation% point", gfc_match_omp_cancellation_point,
- ST_OMP_CANCELLATION_POINT);
- matcho ("cancel", gfc_match_omp_cancel, ST_OMP_CANCEL);
- matcho ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
- break;
- case 'd':
- matchds ("declare reduction", gfc_match_omp_declare_reduction,
- ST_OMP_DECLARE_REDUCTION);
- matcho ("depobj", gfc_match_omp_depobj, ST_OMP_DEPOBJ);
- matchs ("distribute parallel do simd",
- gfc_match_omp_distribute_parallel_do_simd,
- ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD);
- matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do,
- ST_OMP_DISTRIBUTE_PARALLEL_DO);
- matchs ("distribute simd", gfc_match_omp_distribute_simd,
- ST_OMP_DISTRIBUTE_SIMD);
- matcho ("distribute", gfc_match_omp_distribute, ST_OMP_DISTRIBUTE);
- matchs ("do simd", gfc_match_omp_do_simd, ST_OMP_DO_SIMD);
- matcho ("do", gfc_match_omp_do, ST_OMP_DO);
- break;
- case 'e':
- matcho ("error", gfc_match_omp_error, ST_OMP_ERROR);
- matcho ("end atomic", gfc_match_omp_eos_error, ST_OMP_END_ATOMIC);
- matcho ("end critical", gfc_match_omp_end_critical, ST_OMP_END_CRITICAL);
- matchs ("end distribute parallel do simd", gfc_match_omp_eos_error,
- ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD);
- matcho ("end distribute parallel do", gfc_match_omp_eos_error,
- ST_OMP_END_DISTRIBUTE_PARALLEL_DO);
- matchs ("end distribute simd", gfc_match_omp_eos_error,
- ST_OMP_END_DISTRIBUTE_SIMD);
- matcho ("end distribute", gfc_match_omp_eos_error, ST_OMP_END_DISTRIBUTE);
- matchs ("end do simd", gfc_match_omp_end_nowait, ST_OMP_END_DO_SIMD);
- matcho ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
- matcho ("end loop", gfc_match_omp_eos_error, ST_OMP_END_LOOP);
- matchs ("end simd", gfc_match_omp_eos_error, ST_OMP_END_SIMD);
- matcho ("end masked taskloop simd", gfc_match_omp_eos_error,
- ST_OMP_END_MASKED_TASKLOOP_SIMD);
- matcho ("end masked taskloop", gfc_match_omp_eos_error,
- ST_OMP_END_MASKED_TASKLOOP);
- matcho ("end masked", gfc_match_omp_eos_error, ST_OMP_END_MASKED);
- matcho ("end master taskloop simd", gfc_match_omp_eos_error,
- ST_OMP_END_MASTER_TASKLOOP_SIMD);
- matcho ("end master taskloop", gfc_match_omp_eos_error,
- ST_OMP_END_MASTER_TASKLOOP);
- matcho ("end master", gfc_match_omp_eos_error, ST_OMP_END_MASTER);
- matchs ("end ordered", gfc_match_omp_eos_error, ST_OMP_END_ORDERED);
- matchs ("end parallel do simd", gfc_match_omp_eos_error,
- ST_OMP_END_PARALLEL_DO_SIMD);
- matcho ("end parallel do", gfc_match_omp_eos_error, ST_OMP_END_PARALLEL_DO);
- matcho ("end parallel loop", gfc_match_omp_eos_error,
- ST_OMP_END_PARALLEL_LOOP);
- matcho ("end parallel masked taskloop simd", gfc_match_omp_eos_error,
- ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD);
- matcho ("end parallel masked taskloop", gfc_match_omp_eos_error,
- ST_OMP_END_PARALLEL_MASKED_TASKLOOP);
- matcho ("end parallel masked", gfc_match_omp_eos_error,
- ST_OMP_END_PARALLEL_MASKED);
- matcho ("end parallel master taskloop simd", gfc_match_omp_eos_error,
- ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD);
- matcho ("end parallel master taskloop", gfc_match_omp_eos_error,
- ST_OMP_END_PARALLEL_MASTER_TASKLOOP);
- matcho ("end parallel master", gfc_match_omp_eos_error,
- ST_OMP_END_PARALLEL_MASTER);
- matcho ("end parallel sections", gfc_match_omp_eos_error,
- ST_OMP_END_PARALLEL_SECTIONS);
- matcho ("end parallel workshare", gfc_match_omp_eos_error,
- ST_OMP_END_PARALLEL_WORKSHARE);
- matcho ("end parallel", gfc_match_omp_eos_error, ST_OMP_END_PARALLEL);
- matcho ("end scope", gfc_match_omp_end_nowait, ST_OMP_END_SCOPE);
- matcho ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
- matcho ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
- matcho ("end target data", gfc_match_omp_eos_error, ST_OMP_END_TARGET_DATA);
- matchs ("end target parallel do simd", gfc_match_omp_end_nowait,
- ST_OMP_END_TARGET_PARALLEL_DO_SIMD);
- matcho ("end target parallel do", gfc_match_omp_end_nowait,
- ST_OMP_END_TARGET_PARALLEL_DO);
- matcho ("end target parallel loop", gfc_match_omp_end_nowait,
- ST_OMP_END_TARGET_PARALLEL_LOOP);
- matcho ("end target parallel", gfc_match_omp_end_nowait,
- ST_OMP_END_TARGET_PARALLEL);
- matchs ("end target simd", gfc_match_omp_end_nowait, ST_OMP_END_TARGET_SIMD);
- matchs ("end target teams distribute parallel do simd",
- gfc_match_omp_end_nowait,
- ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
- matcho ("end target teams distribute parallel do", gfc_match_omp_end_nowait,
- ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO);
- matchs ("end target teams distribute simd", gfc_match_omp_end_nowait,
- ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD);
- matcho ("end target teams distribute", gfc_match_omp_end_nowait,
- ST_OMP_END_TARGET_TEAMS_DISTRIBUTE);
- matcho ("end target teams loop", gfc_match_omp_end_nowait,
- ST_OMP_END_TARGET_TEAMS_LOOP);
- matcho ("end target teams", gfc_match_omp_end_nowait,
- ST_OMP_END_TARGET_TEAMS);
- matcho ("end target", gfc_match_omp_end_nowait, ST_OMP_END_TARGET);
- matcho ("end taskgroup", gfc_match_omp_eos_error, ST_OMP_END_TASKGROUP);
- matchs ("end taskloop simd", gfc_match_omp_eos_error,
- ST_OMP_END_TASKLOOP_SIMD);
- matcho ("end taskloop", gfc_match_omp_eos_error, ST_OMP_END_TASKLOOP);
- matcho ("end task", gfc_match_omp_eos_error, ST_OMP_END_TASK);
- matchs ("end teams distribute parallel do simd", gfc_match_omp_eos_error,
- ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
- matcho ("end teams distribute parallel do", gfc_match_omp_eos_error,
- ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO);
- matchs ("end teams distribute simd", gfc_match_omp_eos_error,
- ST_OMP_END_TEAMS_DISTRIBUTE_SIMD);
- matcho ("end teams distribute", gfc_match_omp_eos_error,
- ST_OMP_END_TEAMS_DISTRIBUTE);
- matcho ("end teams loop", gfc_match_omp_eos_error, ST_OMP_END_TEAMS_LOOP);
- matcho ("end teams", gfc_match_omp_eos_error, ST_OMP_END_TEAMS);
- matcho ("end workshare", gfc_match_omp_end_nowait,
- ST_OMP_END_WORKSHARE);
- break;
- case 'f':
- matcho ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
- break;
- case 'm':
- matcho ("masked taskloop simd", gfc_match_omp_masked_taskloop_simd,
- ST_OMP_MASKED_TASKLOOP_SIMD);
- matcho ("masked taskloop", gfc_match_omp_masked_taskloop,
- ST_OMP_MASKED_TASKLOOP);
- matcho ("masked", gfc_match_omp_masked, ST_OMP_MASKED);
- matcho ("master taskloop simd", gfc_match_omp_master_taskloop_simd,
- ST_OMP_MASTER_TASKLOOP_SIMD);
- matcho ("master taskloop", gfc_match_omp_master_taskloop,
- ST_OMP_MASTER_TASKLOOP);
- matcho ("master", gfc_match_omp_master, ST_OMP_MASTER);
- break;
- case 'n':
- matcho ("nothing", gfc_match_omp_nothing, ST_NONE);
- break;
- case 'l':
- matcho ("loop", gfc_match_omp_loop, ST_OMP_LOOP);
- break;
- case 'o':
- if (gfc_match ("ordered depend (") == MATCH_YES)
- {
- gfc_current_locus = old_locus;
- if (!flag_openmp)
- break;
- matcho ("ordered", gfc_match_omp_ordered_depend,
- ST_OMP_ORDERED_DEPEND);
- }
- else
- matchs ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
- break;
- case 'p':
- matchs ("parallel do simd", gfc_match_omp_parallel_do_simd,
- ST_OMP_PARALLEL_DO_SIMD);
- matcho ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
- matcho ("parallel loop", gfc_match_omp_parallel_loop,
- ST_OMP_PARALLEL_LOOP);
- matcho ("parallel masked taskloop simd",
- gfc_match_omp_parallel_masked_taskloop_simd,
- ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD);
- matcho ("parallel masked taskloop",
- gfc_match_omp_parallel_masked_taskloop,
- ST_OMP_PARALLEL_MASKED_TASKLOOP);
- matcho ("parallel masked", gfc_match_omp_parallel_masked,
- ST_OMP_PARALLEL_MASKED);
- matcho ("parallel master taskloop simd",
- gfc_match_omp_parallel_master_taskloop_simd,
- ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD);
- matcho ("parallel master taskloop",
- gfc_match_omp_parallel_master_taskloop,
- ST_OMP_PARALLEL_MASTER_TASKLOOP);
- matcho ("parallel master", gfc_match_omp_parallel_master,
- ST_OMP_PARALLEL_MASTER);
- matcho ("parallel sections", gfc_match_omp_parallel_sections,
- ST_OMP_PARALLEL_SECTIONS);
- matcho ("parallel workshare", gfc_match_omp_parallel_workshare,
- ST_OMP_PARALLEL_WORKSHARE);
- matcho ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL);
- break;
- case 'r':
- matcho ("requires", gfc_match_omp_requires, ST_OMP_REQUIRES);
- break;
- case 's':
- matcho ("scan", gfc_match_omp_scan, ST_OMP_SCAN);
- matcho ("scope", gfc_match_omp_scope, ST_OMP_SCOPE);
- matcho ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
- matcho ("section", gfc_match_omp_eos_error, ST_OMP_SECTION);
- matcho ("single", gfc_match_omp_single, ST_OMP_SINGLE);
- break;
- case 't':
- matcho ("target data", gfc_match_omp_target_data, ST_OMP_TARGET_DATA);
- matcho ("target enter data", gfc_match_omp_target_enter_data,
- ST_OMP_TARGET_ENTER_DATA);
- matcho ("target exit data", gfc_match_omp_target_exit_data,
- ST_OMP_TARGET_EXIT_DATA);
- matchs ("target parallel do simd", gfc_match_omp_target_parallel_do_simd,
- ST_OMP_TARGET_PARALLEL_DO_SIMD);
- matcho ("target parallel do", gfc_match_omp_target_parallel_do,
- ST_OMP_TARGET_PARALLEL_DO);
- matcho ("target parallel loop", gfc_match_omp_target_parallel_loop,
- ST_OMP_TARGET_PARALLEL_LOOP);
- matcho ("target parallel", gfc_match_omp_target_parallel,
- ST_OMP_TARGET_PARALLEL);
- matchs ("target simd", gfc_match_omp_target_simd, ST_OMP_TARGET_SIMD);
- matchs ("target teams distribute parallel do simd",
- gfc_match_omp_target_teams_distribute_parallel_do_simd,
- ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
- matcho ("target teams distribute parallel do",
- gfc_match_omp_target_teams_distribute_parallel_do,
- ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO);
- matchs ("target teams distribute simd",
- gfc_match_omp_target_teams_distribute_simd,
- ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD);
- matcho ("target teams distribute", gfc_match_omp_target_teams_distribute,
- ST_OMP_TARGET_TEAMS_DISTRIBUTE);
- matcho ("target teams loop", gfc_match_omp_target_teams_loop,
- ST_OMP_TARGET_TEAMS_LOOP);
- matcho ("target teams", gfc_match_omp_target_teams, ST_OMP_TARGET_TEAMS);
- matcho ("target update", gfc_match_omp_target_update,
- ST_OMP_TARGET_UPDATE);
- matcho ("target", gfc_match_omp_target, ST_OMP_TARGET);
- matcho ("taskgroup", gfc_match_omp_taskgroup, ST_OMP_TASKGROUP);
- matchs ("taskloop simd", gfc_match_omp_taskloop_simd,
- ST_OMP_TASKLOOP_SIMD);
- matcho ("taskloop", gfc_match_omp_taskloop, ST_OMP_TASKLOOP);
- matcho ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT);
- matcho ("taskyield", gfc_match_omp_taskyield, ST_OMP_TASKYIELD);
- matcho ("task", gfc_match_omp_task, ST_OMP_TASK);
- matchs ("teams distribute parallel do simd",
- gfc_match_omp_teams_distribute_parallel_do_simd,
- ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
- matcho ("teams distribute parallel do",
- gfc_match_omp_teams_distribute_parallel_do,
- ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO);
- matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd,
- ST_OMP_TEAMS_DISTRIBUTE_SIMD);
- matcho ("teams distribute", gfc_match_omp_teams_distribute,
- ST_OMP_TEAMS_DISTRIBUTE);
- matcho ("teams loop", gfc_match_omp_teams_loop, ST_OMP_TEAMS_LOOP);
- matcho ("teams", gfc_match_omp_teams, ST_OMP_TEAMS);
- matchdo ("threadprivate", gfc_match_omp_threadprivate,
- ST_OMP_THREADPRIVATE);
- break;
- case 'w':
- matcho ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE);
- break;
- }
-
- /* All else has failed, so give up. See if any of the matchers has
- stored an error message of some sort. Don't error out if
- not -fopenmp and simd_matched is false, i.e. if a directive other
- than one marked with match has been seen. */
-
- error_handling:
- if (flag_openmp || simd_matched)
- {
- if (!gfc_error_check ())
- gfc_error_now ("Unclassifiable OpenMP directive at %C");
- }
-
- reject_statement ();
-
- gfc_error_recovery ();
-
- return ST_NONE;
-
- finish:
- if (!pure_ok)
- {
- gfc_unset_implicit_pure (NULL);
-
- if (!flag_openmp && gfc_pure (NULL))
- {
- gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET "
- "at %C may not appear in PURE procedures");
- reject_statement ();
- gfc_error_recovery ();
- return ST_NONE;
- }
- }
- switch (ret)
- {
- case ST_OMP_DECLARE_TARGET:
- case ST_OMP_TARGET:
- case ST_OMP_TARGET_DATA:
- case ST_OMP_TARGET_ENTER_DATA:
- case ST_OMP_TARGET_EXIT_DATA:
- case ST_OMP_TARGET_TEAMS:
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
- case ST_OMP_TARGET_TEAMS_LOOP:
- case ST_OMP_TARGET_PARALLEL:
- case ST_OMP_TARGET_PARALLEL_DO:
- case ST_OMP_TARGET_PARALLEL_DO_SIMD:
- case ST_OMP_TARGET_PARALLEL_LOOP:
- case ST_OMP_TARGET_SIMD:
- case ST_OMP_TARGET_UPDATE:
- {
- 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;
- }
- prog_unit->omp_target_seen = true;
- break;
- }
- case ST_OMP_ERROR:
- if (new_st.ext.omp_clauses->at != OMP_AT_EXECUTION)
- return ST_NONE;
- default:
- break;
- }
- return ret;
-
- do_spec_only:
- reject_statement ();
- gfc_clear_error ();
- gfc_buffer_error (false);
- gfc_current_locus = old_locus;
- return ST_GET_FCN_CHARACTERISTICS;
-}
-
-static gfc_statement
-decode_gcc_attribute (void)
-{
- locus old_locus;
-
- gfc_enforce_clean_symbol_state ();
-
- gfc_clear_error (); /* Clear any pending errors. */
- gfc_clear_warning (); /* Clear any pending warnings. */
- old_locus = gfc_current_locus;
-
- match ("attributes", gfc_match_gcc_attributes, ST_ATTR_DECL);
- match ("unroll", gfc_match_gcc_unroll, ST_NONE);
- match ("builtin", gfc_match_gcc_builtin, ST_NONE);
- match ("ivdep", gfc_match_gcc_ivdep, ST_NONE);
- match ("vector", gfc_match_gcc_vector, ST_NONE);
- match ("novector", gfc_match_gcc_novector, ST_NONE);
-
- /* All else has failed, so give up. See if any of the matchers has
- stored an error message of some sort. */
-
- if (!gfc_error_check ())
- {
- if (pedantic)
- gfc_error_now ("Unclassifiable GCC directive at %C");
- else
- gfc_warning_now (0, "Unclassifiable GCC directive at %C, ignored");
- }
-
- reject_statement ();
-
- gfc_error_recovery ();
-
- return ST_NONE;
-}
-
-#undef match
-
-/* Assert next length characters to be equal to token in free form. */
-
-static void
-verify_token_free (const char* token, int length, bool last_was_use_stmt)
-{
- int i;
- char c;
-
- c = gfc_next_ascii_char ();
- for (i = 0; i < length; i++, c = gfc_next_ascii_char ())
- gcc_assert (c == token[i]);
-
- gcc_assert (gfc_is_whitespace(c));
- gfc_gobble_whitespace ();
- if (last_was_use_stmt)
- use_modules ();
-}
-
-/* Get the next statement in free form source. */
-
-static gfc_statement
-next_free (void)
-{
- match m;
- int i, cnt, at_bol;
- char c;
-
- at_bol = gfc_at_bol ();
- gfc_gobble_whitespace ();
-
- c = gfc_peek_ascii_char ();
-
- if (ISDIGIT (c))
- {
- char d;
-
- /* Found a statement label? */
- m = gfc_match_st_label (&gfc_statement_label);
-
- d = gfc_peek_ascii_char ();
- if (m != MATCH_YES || !gfc_is_whitespace (d))
- {
- gfc_match_small_literal_int (&i, &cnt);
-
- if (cnt > 5)
- gfc_error_now ("Too many digits in statement label at %C");
-
- if (i == 0)
- gfc_error_now ("Zero is not a valid statement label at %C");
-
- do
- c = gfc_next_ascii_char ();
- while (ISDIGIT(c));
-
- if (!gfc_is_whitespace (c))
- gfc_error_now ("Non-numeric character in statement label at %C");
-
- return ST_NONE;
- }
- else
- {
- label_locus = gfc_current_locus;
-
- gfc_gobble_whitespace ();
-
- if (at_bol && gfc_peek_ascii_char () == ';')
- {
- gfc_error_now ("Semicolon at %C needs to be preceded by "
- "statement");
- gfc_next_ascii_char (); /* Eat up the semicolon. */
- return ST_NONE;
- }
-
- if (gfc_match_eos () == MATCH_YES)
- gfc_error_now ("Statement label without statement at %L",
- &label_locus);
- }
- }
- else if (c == '!')
- {
- /* Comments have already been skipped by the time we get here,
- except for GCC attributes and OpenMP/OpenACC directives. */
-
- gfc_next_ascii_char (); /* Eat up the exclamation sign. */
- c = gfc_peek_ascii_char ();
-
- if (c == 'g')
- {
- int i;
-
- c = gfc_next_ascii_char ();
- for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
- gcc_assert (c == "gcc$"[i]);
-
- gfc_gobble_whitespace ();
- return decode_gcc_attribute ();
-
- }
- else if (c == '$')
- {
- /* Since both OpenMP and OpenACC directives starts with
- !$ character sequence, we must check all flags combinations */
- if ((flag_openmp || flag_openmp_simd)
- && !flag_openacc)
- {
- verify_token_free ("$omp", 4, last_was_use_stmt);
- return decode_omp_directive ();
- }
- else if ((flag_openmp || flag_openmp_simd)
- && flag_openacc)
- {
- gfc_next_ascii_char (); /* Eat up dollar character */
- c = gfc_peek_ascii_char ();
-
- if (c == 'o')
- {
- verify_token_free ("omp", 3, last_was_use_stmt);
- return decode_omp_directive ();
- }
- else if (c == 'a')
- {
- verify_token_free ("acc", 3, last_was_use_stmt);
- return decode_oacc_directive ();
- }
- }
- else if (flag_openacc)
- {
- verify_token_free ("$acc", 4, last_was_use_stmt);
- return decode_oacc_directive ();
- }
- }
- gcc_unreachable ();
- }
-
- if (at_bol && c == ';')
- {
- if (!(gfc_option.allow_std & GFC_STD_F2008))
- gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
- "statement");
- gfc_next_ascii_char (); /* Eat up the semicolon. */
- return ST_NONE;
- }
-
- return decode_statement ();
-}
-
-/* Assert next length characters to be equal to token in fixed form. */
-
-static bool
-verify_token_fixed (const char *token, int length, bool last_was_use_stmt)
-{
- int i;
- char c = gfc_next_char_literal (NONSTRING);
-
- for (i = 0; i < length; i++, c = gfc_next_char_literal (NONSTRING))
- gcc_assert ((char) gfc_wide_tolower (c) == token[i]);
-
- if (c != ' ' && c != '0')
- {
- gfc_buffer_error (false);
- gfc_error ("Bad continuation line at %C");
- return false;
- }
- if (last_was_use_stmt)
- use_modules ();
-
- return true;
-}
-
-/* Get the next statement in fixed-form source. */
-
-static gfc_statement
-next_fixed (void)
-{
- int label, digit_flag, i;
- locus loc;
- gfc_char_t c;
-
- if (!gfc_at_bol ())
- return decode_statement ();
-
- /* Skip past the current label field, parsing a statement label if
- one is there. This is a weird number parser, since the number is
- contained within five columns and can have any kind of embedded
- spaces. We also check for characters that make the rest of the
- line a comment. */
-
- label = 0;
- digit_flag = 0;
-
- for (i = 0; i < 5; i++)
- {
- c = gfc_next_char_literal (NONSTRING);
-
- switch (c)
- {
- case ' ':
- break;
-
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- label = label * 10 + ((unsigned char) c - '0');
- label_locus = gfc_current_locus;
- digit_flag = 1;
- break;
-
- /* Comments have already been skipped by the time we get
- here, except for GCC attributes and OpenMP directives. */
-
- case '*':
- c = gfc_next_char_literal (NONSTRING);
-
- if (TOLOWER (c) == 'g')
- {
- for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
- gcc_assert (TOLOWER (c) == "gcc$"[i]);
-
- return decode_gcc_attribute ();
- }
- else if (c == '$')
- {
- if ((flag_openmp || flag_openmp_simd)
- && !flag_openacc)
- {
- if (!verify_token_fixed ("omp", 3, last_was_use_stmt))
- return ST_NONE;
- return decode_omp_directive ();
- }
- else if ((flag_openmp || flag_openmp_simd)
- && flag_openacc)
- {
- c = gfc_next_char_literal(NONSTRING);
- if (c == 'o' || c == 'O')
- {
- if (!verify_token_fixed ("mp", 2, last_was_use_stmt))
- return ST_NONE;
- return decode_omp_directive ();
- }
- else if (c == 'a' || c == 'A')
- {
- if (!verify_token_fixed ("cc", 2, last_was_use_stmt))
- return ST_NONE;
- return decode_oacc_directive ();
- }
- }
- else if (flag_openacc)
- {
- if (!verify_token_fixed ("acc", 3, last_was_use_stmt))
- return ST_NONE;
- return decode_oacc_directive ();
- }
- }
- gcc_fallthrough ();
-
- /* Comments have already been skipped by the time we get
- here so don't bother checking for them. */
-
- default:
- gfc_buffer_error (false);
- gfc_error ("Non-numeric character in statement label at %C");
- return ST_NONE;
- }
- }
-
- if (digit_flag)
- {
- if (label == 0)
- gfc_warning_now (0, "Zero is not a valid statement label at %C");
- else
- {
- /* We've found a valid statement label. */
- gfc_statement_label = gfc_get_st_label (label);
- }
- }
-
- /* Since this line starts a statement, it cannot be a continuation
- of a previous statement. If we see something here besides a
- space or zero, it must be a bad continuation line. */
-
- c = gfc_next_char_literal (NONSTRING);
- if (c == '\n')
- goto blank_line;
-
- if (c != ' ' && c != '0')
- {
- gfc_buffer_error (false);
- gfc_error ("Bad continuation line at %C");
- return ST_NONE;
- }
-
- /* Now that we've taken care of the statement label columns, we have
- to make sure that the first nonblank character is not a '!'. If
- it is, the rest of the line is a comment. */
-
- do
- {
- loc = gfc_current_locus;
- c = gfc_next_char_literal (NONSTRING);
- }
- while (gfc_is_whitespace (c));
-
- if (c == '!')
- goto blank_line;
- gfc_current_locus = loc;
-
- if (c == ';')
- {
- if (digit_flag)
- gfc_error_now ("Semicolon at %C needs to be preceded by statement");
- else if (!(gfc_option.allow_std & GFC_STD_F2008))
- gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
- "statement");
- return ST_NONE;
- }
-
- if (gfc_match_eos () == MATCH_YES)
- goto blank_line;
-
- /* At this point, we've got a nonblank statement to parse. */
- return decode_statement ();
-
-blank_line:
- if (digit_flag)
- gfc_error_now ("Statement label without statement at %L", &label_locus);
-
- gfc_current_locus.lb->truncated = 0;
- gfc_advance_line ();
- return ST_NONE;
-}
-
-
-/* Return the next non-ST_NONE statement to the caller. We also worry
- about including files and the ends of include files at this stage. */
-
-static gfc_statement
-next_statement (void)
-{
- gfc_statement st;
- locus old_locus;
-
- gfc_enforce_clean_symbol_state ();
-
- gfc_new_block = NULL;
-
- gfc_current_ns->old_equiv = gfc_current_ns->equiv;
- gfc_current_ns->old_data = gfc_current_ns->data;
- for (;;)
- {
- gfc_statement_label = NULL;
- gfc_buffer_error (true);
-
- if (gfc_at_eol ())
- gfc_advance_line ();
-
- gfc_skip_comments ();
-
- if (gfc_at_end ())
- {
- st = ST_NONE;
- break;
- }
-
- if (gfc_define_undef_line ())
- continue;
-
- old_locus = gfc_current_locus;
-
- st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
-
- if (st != ST_NONE)
- break;
- }
-
- gfc_buffer_error (false);
-
- if (st == ST_GET_FCN_CHARACTERISTICS)
- {
- if (gfc_statement_label != NULL)
- {
- gfc_free_st_label (gfc_statement_label);
- gfc_statement_label = NULL;
- }
- gfc_current_locus = old_locus;
- }
-
- if (st != ST_NONE)
- check_statement_label (st);
-
- return st;
-}
-
-
-/****************************** Parser ***********************************/
-
-/* The parser subroutines are of type 'try' that fail if the file ends
- unexpectedly. */
-
-/* Macros that expand to case-labels for various classes of
- statements. Start with executable statements that directly do
- things. */
-
-#define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
- case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
- case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
- case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
- case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
- case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
- case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
- case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
- case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
- case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: case ST_OMP_DEPOBJ: \
- case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \
- case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: case ST_OMP_ERROR: \
- case ST_ERROR_STOP: case ST_OMP_SCAN: case ST_SYNC_ALL: \
- case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
- case ST_FORM_TEAM: case ST_CHANGE_TEAM: \
- case ST_END_TEAM: case ST_SYNC_TEAM: \
- case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \
- case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
- case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
-
-/* Statements that mark other executable statements. */
-
-#define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
- case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
- case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
- case ST_SELECT_RANK: case ST_OMP_PARALLEL: case ST_OMP_PARALLEL_MASKED: \
- case ST_OMP_PARALLEL_MASKED_TASKLOOP: \
- case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: case ST_OMP_PARALLEL_MASTER: \
- case ST_OMP_PARALLEL_MASTER_TASKLOOP: \
- case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: \
- case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
- case ST_OMP_CRITICAL: case ST_OMP_MASKED: case ST_OMP_MASKED_TASKLOOP: \
- case ST_OMP_MASKED_TASKLOOP_SIMD: \
- case ST_OMP_MASTER: case ST_OMP_MASTER_TASKLOOP: \
- case ST_OMP_MASTER_TASKLOOP_SIMD: case ST_OMP_SCOPE: case ST_OMP_SINGLE: \
- case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
- case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
- case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
- case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \
- case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
- case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \
- case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \
- case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
- case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
- case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
- case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_TARGET_PARALLEL: \
- case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: \
- case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \
- case ST_OMP_LOOP: case ST_OMP_PARALLEL_LOOP: case ST_OMP_TEAMS_LOOP: \
- case ST_OMP_TARGET_PARALLEL_LOOP: case ST_OMP_TARGET_TEAMS_LOOP: \
- case ST_CRITICAL: \
- case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
- case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
- case ST_OACC_KERNELS_LOOP: case ST_OACC_SERIAL_LOOP: case ST_OACC_SERIAL: \
- case ST_OACC_ATOMIC
-
-/* Declaration statements */
-
-#define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
- case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
- case ST_TYPE: case ST_INTERFACE: case ST_PROCEDURE
-
-/* OpenMP and OpenACC declaration statements, which may appear anywhere in
- the specification part. */
-
-#define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
- case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \
- case ST_OMP_DECLARE_VARIANT: \
- case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE
-
-/* Block end statements. Errors associated with interchanging these
- are detected in gfc_match_end(). */
-
-#define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
- case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
- case ST_END_BLOCK: case ST_END_ASSOCIATE
-
-
-/* Push a new state onto the stack. */
-
-static void
-push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym)
-{
- p->state = new_state;
- p->previous = gfc_state_stack;
- p->sym = sym;
- p->head = p->tail = NULL;
- p->do_variable = NULL;
- if (p->state != COMP_DO && p->state != COMP_DO_CONCURRENT)
- p->ext.oacc_declare_clauses = NULL;
-
- /* If this the state of a construct like BLOCK, DO or IF, the corresponding
- construct statement was accepted right before pushing the state. Thus,
- the construct's gfc_code is available as tail of the parent state. */
- gcc_assert (gfc_state_stack);
- p->construct = gfc_state_stack->tail;
-
- gfc_state_stack = p;
-}
-
-
-/* Pop the current state. */
-static void
-pop_state (void)
-{
- gfc_state_stack = gfc_state_stack->previous;
-}
-
-
-/* Try to find the given state in the state stack. */
-
-bool
-gfc_find_state (gfc_compile_state state)
-{
- gfc_state_data *p;
-
- for (p = gfc_state_stack; p; p = p->previous)
- if (p->state == state)
- break;
-
- return (p == NULL) ? false : true;
-}
-
-
-/* Starts a new level in the statement list. */
-
-static gfc_code *
-new_level (gfc_code *q)
-{
- gfc_code *p;
-
- p = q->block = gfc_get_code (EXEC_NOP);
-
- gfc_state_stack->head = gfc_state_stack->tail = p;
-
- return p;
-}
-
-
-/* Add the current new_st code structure and adds it to the current
- program unit. As a side-effect, it zeroes the new_st. */
-
-static gfc_code *
-add_statement (void)
-{
- gfc_code *p;
-
- p = XCNEW (gfc_code);
- *p = new_st;
-
- p->loc = gfc_current_locus;
-
- if (gfc_state_stack->head == NULL)
- gfc_state_stack->head = p;
- else
- gfc_state_stack->tail->next = p;
-
- while (p->next != NULL)
- p = p->next;
-
- gfc_state_stack->tail = p;
-
- gfc_clear_new_st ();
-
- return p;
-}
-
-
-/* Frees everything associated with the current statement. */
-
-static void
-undo_new_statement (void)
-{
- gfc_free_statements (new_st.block);
- gfc_free_statements (new_st.next);
- gfc_free_statement (&new_st);
- gfc_clear_new_st ();
-}
-
-
-/* If the current statement has a statement label, make sure that it
- is allowed to, or should have one. */
-
-static void
-check_statement_label (gfc_statement st)
-{
- gfc_sl_type type;
-
- if (gfc_statement_label == NULL)
- {
- if (st == ST_FORMAT)
- gfc_error ("FORMAT statement at %L does not have a statement label",
- &new_st.loc);
- return;
- }
-
- switch (st)
- {
- case ST_END_PROGRAM:
- case ST_END_FUNCTION:
- case ST_END_SUBROUTINE:
- case ST_ENDDO:
- case ST_ENDIF:
- case ST_END_SELECT:
- case ST_END_CRITICAL:
- case ST_END_BLOCK:
- case ST_END_ASSOCIATE:
- case_executable:
- case_exec_markers:
- if (st == ST_ENDDO || st == ST_CONTINUE)
- type = ST_LABEL_DO_TARGET;
- else
- type = ST_LABEL_TARGET;
- break;
-
- case ST_FORMAT:
- type = ST_LABEL_FORMAT;
- break;
-
- /* Statement labels are not restricted from appearing on a
- particular line. However, there are plenty of situations
- where the resulting label can't be referenced. */
-
- default:
- type = ST_LABEL_BAD_TARGET;
- break;
- }
-
- gfc_define_st_label (gfc_statement_label, type, &label_locus);
-
- new_st.here = gfc_statement_label;
-}
-
-
-/* Figures out what the enclosing program unit is. This will be a
- function, subroutine, program, block data or module. */
-
-gfc_state_data *
-gfc_enclosing_unit (gfc_compile_state * result)
-{
- gfc_state_data *p;
-
- for (p = gfc_state_stack; p; p = p->previous)
- if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE
- || p->state == COMP_MODULE || p->state == COMP_SUBMODULE
- || p->state == COMP_BLOCK_DATA || p->state == COMP_PROGRAM)
- {
-
- if (result != NULL)
- *result = p->state;
- return p;
- }
-
- if (result != NULL)
- *result = COMP_PROGRAM;
- return NULL;
-}
-
-
-/* Translate a statement enum to a string. */
-
-const char *
-gfc_ascii_statement (gfc_statement st)
-{
- const char *p;
-
- switch (st)
- {
- case ST_ARITHMETIC_IF:
- p = _("arithmetic IF");
- break;
- case ST_ALLOCATE:
- p = "ALLOCATE";
- break;
- case ST_ASSOCIATE:
- p = "ASSOCIATE";
- break;
- case ST_ATTR_DECL:
- p = _("attribute declaration");
- break;
- case ST_BACKSPACE:
- p = "BACKSPACE";
- break;
- case ST_BLOCK:
- p = "BLOCK";
- break;
- case ST_BLOCK_DATA:
- p = "BLOCK DATA";
- break;
- case ST_CALL:
- p = "CALL";
- break;
- case ST_CASE:
- p = "CASE";
- break;
- case ST_CLOSE:
- p = "CLOSE";
- break;
- case ST_COMMON:
- p = "COMMON";
- break;
- case ST_CONTINUE:
- p = "CONTINUE";
- break;
- case ST_CONTAINS:
- p = "CONTAINS";
- break;
- case ST_CRITICAL:
- p = "CRITICAL";
- break;
- case ST_CYCLE:
- p = "CYCLE";
- break;
- case ST_DATA_DECL:
- p = _("data declaration");
- break;
- case ST_DATA:
- p = "DATA";
- break;
- case ST_DEALLOCATE:
- p = "DEALLOCATE";
- break;
- case ST_MAP:
- p = "MAP";
- break;
- case ST_UNION:
- p = "UNION";
- break;
- case ST_STRUCTURE_DECL:
- p = "STRUCTURE";
- break;
- case ST_DERIVED_DECL:
- p = _("derived type declaration");
- break;
- case ST_DO:
- p = "DO";
- break;
- case ST_ELSE:
- p = "ELSE";
- break;
- case ST_ELSEIF:
- p = "ELSE IF";
- break;
- case ST_ELSEWHERE:
- p = "ELSEWHERE";
- break;
- case ST_EVENT_POST:
- p = "EVENT POST";
- break;
- case ST_EVENT_WAIT:
- p = "EVENT WAIT";
- break;
- case ST_FAIL_IMAGE:
- p = "FAIL IMAGE";
- break;
- case ST_CHANGE_TEAM:
- p = "CHANGE TEAM";
- break;
- case ST_END_TEAM:
- p = "END TEAM";
- break;
- case ST_FORM_TEAM:
- p = "FORM TEAM";
- break;
- case ST_SYNC_TEAM:
- p = "SYNC TEAM";
- break;
- case ST_END_ASSOCIATE:
- p = "END ASSOCIATE";
- break;
- case ST_END_BLOCK:
- p = "END BLOCK";
- break;
- case ST_END_BLOCK_DATA:
- p = "END BLOCK DATA";
- break;
- case ST_END_CRITICAL:
- p = "END CRITICAL";
- break;
- case ST_ENDDO:
- p = "END DO";
- break;
- case ST_END_FILE:
- p = "END FILE";
- break;
- case ST_END_FORALL:
- p = "END FORALL";
- break;
- case ST_END_FUNCTION:
- p = "END FUNCTION";
- break;
- case ST_ENDIF:
- p = "END IF";
- break;
- case ST_END_INTERFACE:
- p = "END INTERFACE";
- break;
- case ST_END_MODULE:
- p = "END MODULE";
- break;
- case ST_END_SUBMODULE:
- p = "END SUBMODULE";
- break;
- case ST_END_PROGRAM:
- p = "END PROGRAM";
- break;
- case ST_END_SELECT:
- p = "END SELECT";
- break;
- case ST_END_SUBROUTINE:
- p = "END SUBROUTINE";
- break;
- case ST_END_WHERE:
- p = "END WHERE";
- break;
- case ST_END_STRUCTURE:
- p = "END STRUCTURE";
- break;
- case ST_END_UNION:
- p = "END UNION";
- break;
- case ST_END_MAP:
- p = "END MAP";
- break;
- case ST_END_TYPE:
- p = "END TYPE";
- break;
- case ST_ENTRY:
- p = "ENTRY";
- break;
- case ST_EQUIVALENCE:
- p = "EQUIVALENCE";
- break;
- case ST_ERROR_STOP:
- p = "ERROR STOP";
- break;
- case ST_EXIT:
- p = "EXIT";
- break;
- case ST_FLUSH:
- p = "FLUSH";
- break;
- case ST_FORALL_BLOCK: /* Fall through */
- case ST_FORALL:
- p = "FORALL";
- break;
- case ST_FORMAT:
- p = "FORMAT";
- break;
- case ST_FUNCTION:
- p = "FUNCTION";
- break;
- case ST_GENERIC:
- p = "GENERIC";
- break;
- case ST_GOTO:
- p = "GOTO";
- break;
- case ST_IF_BLOCK:
- p = _("block IF");
- break;
- case ST_IMPLICIT:
- p = "IMPLICIT";
- break;
- case ST_IMPLICIT_NONE:
- p = "IMPLICIT NONE";
- break;
- case ST_IMPLIED_ENDDO:
- p = _("implied END DO");
- break;
- case ST_IMPORT:
- p = "IMPORT";
- break;
- case ST_INQUIRE:
- p = "INQUIRE";
- break;
- case ST_INTERFACE:
- p = "INTERFACE";
- break;
- case ST_LOCK:
- p = "LOCK";
- break;
- case ST_PARAMETER:
- p = "PARAMETER";
- break;
- case ST_PRIVATE:
- p = "PRIVATE";
- break;
- case ST_PUBLIC:
- p = "PUBLIC";
- break;
- case ST_MODULE:
- p = "MODULE";
- break;
- case ST_SUBMODULE:
- p = "SUBMODULE";
- break;
- case ST_PAUSE:
- p = "PAUSE";
- break;
- case ST_MODULE_PROC:
- p = "MODULE PROCEDURE";
- break;
- case ST_NAMELIST:
- p = "NAMELIST";
- break;
- case ST_NULLIFY:
- p = "NULLIFY";
- break;
- case ST_OPEN:
- p = "OPEN";
- break;
- case ST_PROGRAM:
- p = "PROGRAM";
- break;
- case ST_PROCEDURE:
- p = "PROCEDURE";
- break;
- case ST_READ:
- p = "READ";
- break;
- case ST_RETURN:
- p = "RETURN";
- break;
- case ST_REWIND:
- p = "REWIND";
- break;
- case ST_STOP:
- p = "STOP";
- break;
- case ST_SYNC_ALL:
- p = "SYNC ALL";
- break;
- case ST_SYNC_IMAGES:
- p = "SYNC IMAGES";
- break;
- case ST_SYNC_MEMORY:
- p = "SYNC MEMORY";
- break;
- case ST_SUBROUTINE:
- p = "SUBROUTINE";
- break;
- case ST_TYPE:
- p = "TYPE";
- break;
- case ST_UNLOCK:
- p = "UNLOCK";
- break;
- case ST_USE:
- p = "USE";
- break;
- case ST_WHERE_BLOCK: /* Fall through */
- case ST_WHERE:
- p = "WHERE";
- break;
- case ST_WAIT:
- p = "WAIT";
- break;
- case ST_WRITE:
- p = "WRITE";
- break;
- case ST_ASSIGNMENT:
- p = _("assignment");
- break;
- case ST_POINTER_ASSIGNMENT:
- p = _("pointer assignment");
- break;
- case ST_SELECT_CASE:
- p = "SELECT CASE";
- break;
- case ST_SELECT_TYPE:
- p = "SELECT TYPE";
- break;
- case ST_SELECT_RANK:
- p = "SELECT RANK";
- break;
- case ST_TYPE_IS:
- p = "TYPE IS";
- break;
- case ST_CLASS_IS:
- p = "CLASS IS";
- break;
- case ST_RANK:
- p = "RANK";
- break;
- case ST_SEQUENCE:
- p = "SEQUENCE";
- break;
- case ST_SIMPLE_IF:
- p = _("simple IF");
- break;
- case ST_STATEMENT_FUNCTION:
- p = "STATEMENT FUNCTION";
- break;
- case ST_LABEL_ASSIGNMENT:
- p = "LABEL ASSIGNMENT";
- break;
- case ST_ENUM:
- p = "ENUM DEFINITION";
- break;
- case ST_ENUMERATOR:
- p = "ENUMERATOR DEFINITION";
- break;
- case ST_END_ENUM:
- p = "END ENUM";
- break;
- case ST_OACC_PARALLEL_LOOP:
- p = "!$ACC PARALLEL LOOP";
- break;
- case ST_OACC_END_PARALLEL_LOOP:
- p = "!$ACC END PARALLEL LOOP";
- break;
- case ST_OACC_PARALLEL:
- p = "!$ACC PARALLEL";
- break;
- case ST_OACC_END_PARALLEL:
- p = "!$ACC END PARALLEL";
- break;
- case ST_OACC_KERNELS:
- p = "!$ACC KERNELS";
- break;
- case ST_OACC_END_KERNELS:
- p = "!$ACC END KERNELS";
- break;
- case ST_OACC_KERNELS_LOOP:
- p = "!$ACC KERNELS LOOP";
- break;
- case ST_OACC_END_KERNELS_LOOP:
- p = "!$ACC END KERNELS LOOP";
- break;
- case ST_OACC_SERIAL_LOOP:
- p = "!$ACC SERIAL LOOP";
- break;
- case ST_OACC_END_SERIAL_LOOP:
- p = "!$ACC END SERIAL LOOP";
- break;
- case ST_OACC_SERIAL:
- p = "!$ACC SERIAL";
- break;
- case ST_OACC_END_SERIAL:
- p = "!$ACC END SERIAL";
- break;
- case ST_OACC_DATA:
- p = "!$ACC DATA";
- break;
- case ST_OACC_END_DATA:
- p = "!$ACC END DATA";
- break;
- case ST_OACC_HOST_DATA:
- p = "!$ACC HOST_DATA";
- break;
- case ST_OACC_END_HOST_DATA:
- p = "!$ACC END HOST_DATA";
- break;
- case ST_OACC_LOOP:
- p = "!$ACC LOOP";
- break;
- case ST_OACC_END_LOOP:
- p = "!$ACC END LOOP";
- break;
- case ST_OACC_DECLARE:
- p = "!$ACC DECLARE";
- break;
- case ST_OACC_UPDATE:
- p = "!$ACC UPDATE";
- break;
- case ST_OACC_WAIT:
- p = "!$ACC WAIT";
- break;
- case ST_OACC_CACHE:
- p = "!$ACC CACHE";
- break;
- case ST_OACC_ENTER_DATA:
- p = "!$ACC ENTER DATA";
- break;
- case ST_OACC_EXIT_DATA:
- p = "!$ACC EXIT DATA";
- break;
- case ST_OACC_ROUTINE:
- p = "!$ACC ROUTINE";
- break;
- case ST_OACC_ATOMIC:
- p = "!$ACC ATOMIC";
- break;
- case ST_OACC_END_ATOMIC:
- p = "!$ACC END ATOMIC";
- break;
- case ST_OMP_ATOMIC:
- p = "!$OMP ATOMIC";
- break;
- case ST_OMP_BARRIER:
- p = "!$OMP BARRIER";
- break;
- case ST_OMP_CANCEL:
- p = "!$OMP CANCEL";
- break;
- case ST_OMP_CANCELLATION_POINT:
- p = "!$OMP CANCELLATION POINT";
- break;
- case ST_OMP_CRITICAL:
- p = "!$OMP CRITICAL";
- break;
- case ST_OMP_DECLARE_REDUCTION:
- p = "!$OMP DECLARE REDUCTION";
- break;
- case ST_OMP_DECLARE_SIMD:
- p = "!$OMP DECLARE SIMD";
- break;
- case ST_OMP_DECLARE_TARGET:
- p = "!$OMP DECLARE TARGET";
- break;
- case ST_OMP_DECLARE_VARIANT:
- p = "!$OMP DECLARE VARIANT";
- break;
- case ST_OMP_DEPOBJ:
- p = "!$OMP DEPOBJ";
- break;
- case ST_OMP_DISTRIBUTE:
- p = "!$OMP DISTRIBUTE";
- break;
- case ST_OMP_DISTRIBUTE_PARALLEL_DO:
- p = "!$OMP DISTRIBUTE PARALLEL DO";
- break;
- case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
- p = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
- break;
- case ST_OMP_DISTRIBUTE_SIMD:
- p = "!$OMP DISTRIBUTE SIMD";
- break;
- case ST_OMP_DO:
- p = "!$OMP DO";
- break;
- case ST_OMP_DO_SIMD:
- p = "!$OMP DO SIMD";
- break;
- case ST_OMP_END_ATOMIC:
- p = "!$OMP END ATOMIC";
- break;
- case ST_OMP_END_CRITICAL:
- p = "!$OMP END CRITICAL";
- break;
- case ST_OMP_END_DISTRIBUTE:
- p = "!$OMP END DISTRIBUTE";
- break;
- case ST_OMP_END_DISTRIBUTE_PARALLEL_DO:
- p = "!$OMP END DISTRIBUTE PARALLEL DO";
- break;
- case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD:
- p = "!$OMP END DISTRIBUTE PARALLEL DO SIMD";
- break;
- case ST_OMP_END_DISTRIBUTE_SIMD:
- p = "!$OMP END DISTRIBUTE SIMD";
- break;
- case ST_OMP_END_DO:
- p = "!$OMP END DO";
- break;
- case ST_OMP_END_DO_SIMD:
- p = "!$OMP END DO SIMD";
- break;
- case ST_OMP_END_SCOPE:
- p = "!$OMP END SCOPE";
- break;
- case ST_OMP_END_SIMD:
- p = "!$OMP END SIMD";
- break;
- case ST_OMP_END_LOOP:
- p = "!$OMP END LOOP";
- break;
- case ST_OMP_END_MASKED:
- p = "!$OMP END MASKED";
- break;
- case ST_OMP_END_MASKED_TASKLOOP:
- p = "!$OMP END MASKED TASKLOOP";
- break;
- case ST_OMP_END_MASKED_TASKLOOP_SIMD:
- p = "!$OMP END MASKED TASKLOOP SIMD";
- break;
- case ST_OMP_END_MASTER:
- p = "!$OMP END MASTER";
- break;
- case ST_OMP_END_MASTER_TASKLOOP:
- p = "!$OMP END MASTER TASKLOOP";
- break;
- case ST_OMP_END_MASTER_TASKLOOP_SIMD:
- p = "!$OMP END MASTER TASKLOOP SIMD";
- break;
- case ST_OMP_END_ORDERED:
- p = "!$OMP END ORDERED";
- break;
- case ST_OMP_END_PARALLEL:
- p = "!$OMP END PARALLEL";
- break;
- case ST_OMP_END_PARALLEL_DO:
- p = "!$OMP END PARALLEL DO";
- break;
- case ST_OMP_END_PARALLEL_DO_SIMD:
- p = "!$OMP END PARALLEL DO SIMD";
- break;
- case ST_OMP_END_PARALLEL_LOOP:
- p = "!$OMP END PARALLEL LOOP";
- break;
- case ST_OMP_END_PARALLEL_MASKED:
- p = "!$OMP END PARALLEL MASKED";
- break;
- case ST_OMP_END_PARALLEL_MASKED_TASKLOOP:
- p = "!$OMP END PARALLEL MASKED TASKLOOP";
- break;
- case ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD:
- p = "!$OMP END PARALLEL MASKED TASKLOOP SIMD";
- break;
- case ST_OMP_END_PARALLEL_MASTER:
- p = "!$OMP END PARALLEL MASTER";
- break;
- case ST_OMP_END_PARALLEL_MASTER_TASKLOOP:
- p = "!$OMP END PARALLEL MASTER TASKLOOP";
- break;
- case ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD:
- p = "!$OMP END PARALLEL MASTER TASKLOOP SIMD";
- break;
- case ST_OMP_END_PARALLEL_SECTIONS:
- p = "!$OMP END PARALLEL SECTIONS";
- break;
- case ST_OMP_END_PARALLEL_WORKSHARE:
- p = "!$OMP END PARALLEL WORKSHARE";
- break;
- case ST_OMP_END_SECTIONS:
- p = "!$OMP END SECTIONS";
- break;
- case ST_OMP_END_SINGLE:
- p = "!$OMP END SINGLE";
- break;
- case ST_OMP_END_TASK:
- p = "!$OMP END TASK";
- break;
- case ST_OMP_END_TARGET:
- p = "!$OMP END TARGET";
- break;
- case ST_OMP_END_TARGET_DATA:
- p = "!$OMP END TARGET DATA";
- break;
- case ST_OMP_END_TARGET_PARALLEL:
- p = "!$OMP END TARGET PARALLEL";
- break;
- case ST_OMP_END_TARGET_PARALLEL_DO:
- p = "!$OMP END TARGET PARALLEL DO";
- break;
- case ST_OMP_END_TARGET_PARALLEL_DO_SIMD:
- p = "!$OMP END TARGET PARALLEL DO SIMD";
- break;
- case ST_OMP_END_TARGET_PARALLEL_LOOP:
- p = "!$OMP END TARGET PARALLEL LOOP";
- break;
- case ST_OMP_END_TARGET_SIMD:
- p = "!$OMP END TARGET SIMD";
- break;
- case ST_OMP_END_TARGET_TEAMS:
- p = "!$OMP END TARGET TEAMS";
- break;
- case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE:
- p = "!$OMP END TARGET TEAMS DISTRIBUTE";
- break;
- case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
- p = "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO";
- break;
- case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
- p = "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
- break;
- case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD:
- p = "!$OMP END TARGET TEAMS DISTRIBUTE SIMD";
- break;
- case ST_OMP_END_TARGET_TEAMS_LOOP:
- p = "!$OMP END TARGET TEAMS LOOP";
- break;
- case ST_OMP_END_TASKGROUP:
- p = "!$OMP END TASKGROUP";
- break;
- case ST_OMP_END_TASKLOOP:
- p = "!$OMP END TASKLOOP";
- break;
- case ST_OMP_END_TASKLOOP_SIMD:
- p = "!$OMP END TASKLOOP SIMD";
- break;
- case ST_OMP_END_TEAMS:
- p = "!$OMP END TEAMS";
- break;
- case ST_OMP_END_TEAMS_DISTRIBUTE:
- p = "!$OMP END TEAMS DISTRIBUTE";
- break;
- case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO:
- p = "!$OMP END TEAMS DISTRIBUTE PARALLEL DO";
- break;
- case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
- p = "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD";
- break;
- case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD:
- p = "!$OMP END TEAMS DISTRIBUTE SIMD";
- break;
- case ST_OMP_END_TEAMS_LOOP:
- p = "!$OMP END TEAMS LOOP";
- break;
- case ST_OMP_END_WORKSHARE:
- p = "!$OMP END WORKSHARE";
- break;
- case ST_OMP_ERROR:
- p = "!$OMP ERROR";
- break;
- case ST_OMP_FLUSH:
- p = "!$OMP FLUSH";
- break;
- case ST_OMP_LOOP:
- p = "!$OMP LOOP";
- break;
- case ST_OMP_MASKED:
- p = "!$OMP MASKED";
- break;
- case ST_OMP_MASKED_TASKLOOP:
- p = "!$OMP MASKED TASKLOOP";
- break;
- case ST_OMP_MASKED_TASKLOOP_SIMD:
- p = "!$OMP MASKED TASKLOOP SIMD";
- break;
- case ST_OMP_MASTER:
- p = "!$OMP MASTER";
- break;
- case ST_OMP_MASTER_TASKLOOP:
- p = "!$OMP MASTER TASKLOOP";
- break;
- case ST_OMP_MASTER_TASKLOOP_SIMD:
- p = "!$OMP MASTER TASKLOOP SIMD";
- break;
- case ST_OMP_ORDERED:
- case ST_OMP_ORDERED_DEPEND:
- p = "!$OMP ORDERED";
- break;
- case ST_OMP_PARALLEL:
- p = "!$OMP PARALLEL";
- break;
- case ST_OMP_PARALLEL_DO:
- p = "!$OMP PARALLEL DO";
- break;
- case ST_OMP_PARALLEL_LOOP:
- p = "!$OMP PARALLEL LOOP";
- break;
- case ST_OMP_PARALLEL_DO_SIMD:
- p = "!$OMP PARALLEL DO SIMD";
- break;
- case ST_OMP_PARALLEL_MASKED:
- p = "!$OMP PARALLEL MASKED";
- break;
- case ST_OMP_PARALLEL_MASKED_TASKLOOP:
- p = "!$OMP PARALLEL MASKED TASKLOOP";
- break;
- case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
- p = "!$OMP PARALLEL MASKED TASKLOOP SIMD";
- break;
- case ST_OMP_PARALLEL_MASTER:
- p = "!$OMP PARALLEL MASTER";
- break;
- case ST_OMP_PARALLEL_MASTER_TASKLOOP:
- p = "!$OMP PARALLEL MASTER TASKLOOP";
- break;
- case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
- p = "!$OMP PARALLEL MASTER TASKLOOP SIMD";
- break;
- case ST_OMP_PARALLEL_SECTIONS:
- p = "!$OMP PARALLEL SECTIONS";
- break;
- case ST_OMP_PARALLEL_WORKSHARE:
- p = "!$OMP PARALLEL WORKSHARE";
- break;
- case ST_OMP_REQUIRES:
- p = "!$OMP REQUIRES";
- break;
- case ST_OMP_SCAN:
- p = "!$OMP SCAN";
- break;
- case ST_OMP_SCOPE:
- p = "!$OMP SCOPE";
- break;
- case ST_OMP_SECTIONS:
- p = "!$OMP SECTIONS";
- break;
- case ST_OMP_SECTION:
- p = "!$OMP SECTION";
- break;
- case ST_OMP_SIMD:
- p = "!$OMP SIMD";
- break;
- case ST_OMP_SINGLE:
- p = "!$OMP SINGLE";
- break;
- case ST_OMP_TARGET:
- p = "!$OMP TARGET";
- break;
- case ST_OMP_TARGET_DATA:
- p = "!$OMP TARGET DATA";
- break;
- case ST_OMP_TARGET_ENTER_DATA:
- p = "!$OMP TARGET ENTER DATA";
- break;
- case ST_OMP_TARGET_EXIT_DATA:
- p = "!$OMP TARGET EXIT DATA";
- break;
- case ST_OMP_TARGET_PARALLEL:
- p = "!$OMP TARGET PARALLEL";
- break;
- case ST_OMP_TARGET_PARALLEL_DO:
- p = "!$OMP TARGET PARALLEL DO";
- break;
- case ST_OMP_TARGET_PARALLEL_DO_SIMD:
- p = "!$OMP TARGET PARALLEL DO SIMD";
- break;
- case ST_OMP_TARGET_PARALLEL_LOOP:
- p = "!$OMP TARGET PARALLEL LOOP";
- break;
- case ST_OMP_TARGET_SIMD:
- p = "!$OMP TARGET SIMD";
- break;
- case ST_OMP_TARGET_TEAMS:
- p = "!$OMP TARGET TEAMS";
- break;
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
- p = "!$OMP TARGET TEAMS DISTRIBUTE";
- break;
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
- p = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
- break;
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
- p = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
- break;
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
- p = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
- break;
- case ST_OMP_TARGET_TEAMS_LOOP:
- p = "!$OMP TARGET TEAMS LOOP";
- break;
- case ST_OMP_TARGET_UPDATE:
- p = "!$OMP TARGET UPDATE";
- break;
- case ST_OMP_TASK:
- p = "!$OMP TASK";
- break;
- case ST_OMP_TASKGROUP:
- p = "!$OMP TASKGROUP";
- break;
- case ST_OMP_TASKLOOP:
- p = "!$OMP TASKLOOP";
- break;
- case ST_OMP_TASKLOOP_SIMD:
- p = "!$OMP TASKLOOP SIMD";
- break;
- case ST_OMP_TASKWAIT:
- p = "!$OMP TASKWAIT";
- break;
- case ST_OMP_TASKYIELD:
- p = "!$OMP TASKYIELD";
- break;
- case ST_OMP_TEAMS:
- p = "!$OMP TEAMS";
- break;
- case ST_OMP_TEAMS_DISTRIBUTE:
- p = "!$OMP TEAMS DISTRIBUTE";
- break;
- case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
- p = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
- break;
- case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
- p = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
- break;
- case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
- p = "!$OMP TEAMS DISTRIBUTE SIMD";
- break;
- case ST_OMP_TEAMS_LOOP:
- p = "!$OMP TEAMS LOOP";
- break;
- case ST_OMP_THREADPRIVATE:
- p = "!$OMP THREADPRIVATE";
- break;
- case ST_OMP_WORKSHARE:
- p = "!$OMP WORKSHARE";
- break;
- default:
- gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
- }
-
- return p;
-}
-
-
-/* Create a symbol for the main program and assign it to ns->proc_name. */
-
-static void
-main_program_symbol (gfc_namespace *ns, const char *name)
-{
- gfc_symbol *main_program;
- symbol_attribute attr;
-
- gfc_get_symbol (name, ns, &main_program);
- gfc_clear_attr (&attr);
- attr.flavor = FL_PROGRAM;
- attr.proc = PROC_UNKNOWN;
- attr.subroutine = 1;
- attr.access = ACCESS_PUBLIC;
- attr.is_main_program = 1;
- main_program->attr = attr;
- main_program->declared_at = gfc_current_locus;
- ns->proc_name = main_program;
- gfc_commit_symbols ();
-}
-
-
-/* Do whatever is necessary to accept the last statement. */
-
-static void
-accept_statement (gfc_statement st)
-{
- switch (st)
- {
- case ST_IMPLICIT_NONE:
- case ST_IMPLICIT:
- break;
-
- case ST_FUNCTION:
- case ST_SUBROUTINE:
- case ST_MODULE:
- case ST_SUBMODULE:
- gfc_current_ns->proc_name = gfc_new_block;
- break;
-
- /* If the statement is the end of a block, lay down a special code
- that allows a branch to the end of the block from within the
- construct. IF and SELECT are treated differently from DO
- (where EXEC_NOP is added inside the loop) for two
- reasons:
- 1. END DO has a meaning in the sense that after a GOTO to
- it, the loop counter must be increased.
- 2. IF blocks and SELECT blocks can consist of multiple
- parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
- Putting the label before the END IF would make the jump
- from, say, the ELSE IF block to the END IF illegal. */
-
- case ST_ENDIF:
- case ST_END_SELECT:
- case ST_END_CRITICAL:
- if (gfc_statement_label != NULL)
- {
- new_st.op = EXEC_END_NESTED_BLOCK;
- add_statement ();
- }
- break;
-
- /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
- one parallel block. Thus, we add the special code to the nested block
- itself, instead of the parent one. */
- case ST_END_BLOCK:
- case ST_END_ASSOCIATE:
- if (gfc_statement_label != NULL)
- {
- new_st.op = EXEC_END_BLOCK;
- add_statement ();
- }
- break;
-
- /* The end-of-program unit statements do not get the special
- marker and require a statement of some sort if they are a
- branch target. */
-
- case ST_END_PROGRAM:
- case ST_END_FUNCTION:
- case ST_END_SUBROUTINE:
- if (gfc_statement_label != NULL)
- {
- new_st.op = EXEC_RETURN;
- add_statement ();
- }
- else
- {
- new_st.op = EXEC_END_PROCEDURE;
- add_statement ();
- }
-
- break;
-
- case ST_ENTRY:
- case_executable:
- case_exec_markers:
- add_statement ();
- break;
-
- default:
- break;
- }
-
- gfc_commit_symbols ();
- gfc_warning_check ();
- gfc_clear_new_st ();
-}
-
-
-/* Undo anything tentative that has been built for the current statement,
- except if a gfc_charlen structure has been added to current namespace's
- list of gfc_charlen structure. */
-
-static void
-reject_statement (void)
-{
- gfc_free_equiv_until (gfc_current_ns->equiv, gfc_current_ns->old_equiv);
- gfc_current_ns->equiv = gfc_current_ns->old_equiv;
-
- gfc_reject_data (gfc_current_ns);
-
- gfc_new_block = NULL;
- gfc_undo_symbols ();
- gfc_clear_warning ();
- undo_new_statement ();
-}
-
-
-/* Generic complaint about an out of order statement. We also do
- whatever is necessary to clean up. */
-
-static void
-unexpected_statement (gfc_statement st)
-{
- gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st));
-
- reject_statement ();
-}
-
-
-/* Given the next statement seen by the matcher, make sure that it is
- in proper order with the last. This subroutine is initialized by
- calling it with an argument of ST_NONE. If there is a problem, we
- issue an error and return false. Otherwise we return true.
-
- Individual parsers need to verify that the statements seen are
- valid before calling here, i.e., ENTRY statements are not allowed in
- INTERFACE blocks. The following diagram is taken from the standard:
-
- +---------------------------------------+
- | program subroutine function module |
- +---------------------------------------+
- | use |
- +---------------------------------------+
- | import |
- +---------------------------------------+
- | | implicit none |
- | +-----------+------------------+
- | | parameter | implicit |
- | +-----------+------------------+
- | format | | derived type |
- | entry | parameter | interface |
- | | data | specification |
- | | | statement func |
- | +-----------+------------------+
- | | data | executable |
- +--------+-----------+------------------+
- | contains |
- +---------------------------------------+
- | internal module/subprogram |
- +---------------------------------------+
- | end |
- +---------------------------------------+
-
-*/
-
-enum state_order
-{
- ORDER_START,
- ORDER_USE,
- ORDER_IMPORT,
- ORDER_IMPLICIT_NONE,
- ORDER_IMPLICIT,
- ORDER_SPEC,
- ORDER_EXEC
-};
-
-typedef struct
-{
- enum state_order state;
- gfc_statement last_statement;
- locus where;
-}
-st_state;
-
-static bool
-verify_st_order (st_state *p, gfc_statement st, bool silent)
-{
-
- switch (st)
- {
- case ST_NONE:
- p->state = ORDER_START;
- break;
-
- case ST_USE:
- if (p->state > ORDER_USE)
- goto order;
- p->state = ORDER_USE;
- break;
-
- case ST_IMPORT:
- if (p->state > ORDER_IMPORT)
- goto order;
- p->state = ORDER_IMPORT;
- break;
-
- case ST_IMPLICIT_NONE:
- if (p->state > ORDER_IMPLICIT)
- goto order;
-
- /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
- statement disqualifies a USE but not an IMPLICIT NONE.
- Duplicate IMPLICIT NONEs are caught when the implicit types
- are set. */
-
- p->state = ORDER_IMPLICIT_NONE;
- break;
-
- case ST_IMPLICIT:
- if (p->state > ORDER_IMPLICIT)
- goto order;
- p->state = ORDER_IMPLICIT;
- break;
-
- case ST_FORMAT:
- case ST_ENTRY:
- if (p->state < ORDER_IMPLICIT_NONE)
- p->state = ORDER_IMPLICIT_NONE;
- break;
-
- case ST_PARAMETER:
- if (p->state >= ORDER_EXEC)
- goto order;
- if (p->state < ORDER_IMPLICIT)
- p->state = ORDER_IMPLICIT;
- break;
-
- case ST_DATA:
- if (p->state < ORDER_SPEC)
- p->state = ORDER_SPEC;
- break;
-
- case ST_PUBLIC:
- case ST_PRIVATE:
- case ST_STRUCTURE_DECL:
- case ST_DERIVED_DECL:
- case_decl:
- if (p->state >= ORDER_EXEC)
- goto order;
- if (p->state < ORDER_SPEC)
- p->state = ORDER_SPEC;
- break;
-
- case_omp_decl:
- /* The OpenMP/OpenACC directives have to be somewhere in the specification
- part, but there are no further requirements on their ordering.
- Thus don't adjust p->state, just ignore them. */
- if (p->state >= ORDER_EXEC)
- goto order;
- break;
-
- case_executable:
- case_exec_markers:
- if (p->state < ORDER_EXEC)
- p->state = ORDER_EXEC;
- break;
-
- default:
- return false;
- }
-
- /* All is well, record the statement in case we need it next time. */
- p->where = gfc_current_locus;
- p->last_statement = st;
- return true;
-
-order:
- if (!silent)
- gfc_error ("%s statement at %C cannot follow %s statement at %L",
- gfc_ascii_statement (st),
- gfc_ascii_statement (p->last_statement), &p->where);
-
- return false;
-}
-
-
-/* Handle an unexpected end of file. This is a show-stopper... */
-
-static void unexpected_eof (void) ATTRIBUTE_NORETURN;
-
-static void
-unexpected_eof (void)
-{
- gfc_state_data *p;
-
- gfc_error ("Unexpected end of file in %qs", gfc_source_file);
-
- /* Memory cleanup. Move to "second to last". */
- for (p = gfc_state_stack; p && p->previous && p->previous->previous;
- p = p->previous);
-
- gfc_current_ns->code = (p && p->previous) ? p->head : NULL;
- gfc_done_2 ();
-
- longjmp (eof_buf, 1);
-
- /* Avoids build error on systems where longjmp is not declared noreturn. */
- gcc_unreachable ();
-}
-
-
-/* Parse the CONTAINS section of a derived type definition. */
-
-gfc_access gfc_typebound_default_access;
-
-static bool
-parse_derived_contains (void)
-{
- gfc_state_data s;
- bool seen_private = false;
- bool seen_comps = false;
- bool error_flag = false;
- bool to_finish;
-
- gcc_assert (gfc_current_state () == COMP_DERIVED);
- gcc_assert (gfc_current_block ());
-
- /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
- section. */
- if (gfc_current_block ()->attr.sequence)
- gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS"
- " section at %C", gfc_current_block ()->name);
- if (gfc_current_block ()->attr.is_bind_c)
- gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS"
- " section at %C", gfc_current_block ()->name);
-
- accept_statement (ST_CONTAINS);
- push_state (&s, COMP_DERIVED_CONTAINS, NULL);
-
- gfc_typebound_default_access = ACCESS_PUBLIC;
-
- to_finish = false;
- while (!to_finish)
- {
- gfc_statement st;
- st = next_statement ();
- switch (st)
- {
- case ST_NONE:
- unexpected_eof ();
- break;
-
- case ST_DATA_DECL:
- gfc_error ("Components in TYPE at %C must precede CONTAINS");
- goto error;
-
- case ST_PROCEDURE:
- if (!gfc_notify_std (GFC_STD_F2003, "Type-bound procedure at %C"))
- goto error;
-
- accept_statement (ST_PROCEDURE);
- seen_comps = true;
- break;
-
- case ST_GENERIC:
- if (!gfc_notify_std (GFC_STD_F2003, "GENERIC binding at %C"))
- goto error;
-
- accept_statement (ST_GENERIC);
- seen_comps = true;
- break;
-
- case ST_FINAL:
- if (!gfc_notify_std (GFC_STD_F2003, "FINAL procedure declaration"
- " at %C"))
- goto error;
-
- accept_statement (ST_FINAL);
- seen_comps = true;
- break;
-
- case ST_END_TYPE:
- to_finish = true;
-
- if (!seen_comps
- && (!gfc_notify_std(GFC_STD_F2008, "Derived type definition "
- "at %C with empty CONTAINS section")))
- goto error;
-
- /* ST_END_TYPE is accepted by parse_derived after return. */
- break;
-
- case ST_PRIVATE:
- if (!gfc_find_state (COMP_MODULE))
- {
- gfc_error ("PRIVATE statement in TYPE at %C must be inside "
- "a MODULE");
- goto error;
- }
-
- if (seen_comps)
- {
- gfc_error ("PRIVATE statement at %C must precede procedure"
- " bindings");
- goto error;
- }
-
- if (seen_private)
- {
- gfc_error ("Duplicate PRIVATE statement at %C");
- goto error;
- }
-
- accept_statement (ST_PRIVATE);
- gfc_typebound_default_access = ACCESS_PRIVATE;
- seen_private = true;
- break;
-
- case ST_SEQUENCE:
- gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
- goto error;
-
- case ST_CONTAINS:
- gfc_error ("Already inside a CONTAINS block at %C");
- goto error;
-
- default:
- unexpected_statement (st);
- break;
- }
-
- continue;
-
-error:
- error_flag = true;
- reject_statement ();
- }
-
- pop_state ();
- gcc_assert (gfc_current_state () == COMP_DERIVED);
-
- return error_flag;
-}
-
-
-/* Set attributes for the parent symbol based on the attributes of a component
- and raise errors if conflicting attributes are found for the component. */
-
-static void
-check_component (gfc_symbol *sym, gfc_component *c, gfc_component **lockp,
- gfc_component **eventp)
-{
- bool coarray, lock_type, event_type, allocatable, pointer;
- coarray = lock_type = event_type = allocatable = pointer = false;
- gfc_component *lock_comp = NULL, *event_comp = NULL;
-
- if (lockp) lock_comp = *lockp;
- if (eventp) event_comp = *eventp;
-
- /* Look for allocatable components. */
- if (c->attr.allocatable
- || (c->ts.type == BT_CLASS && c->attr.class_ok
- && CLASS_DATA (c)->attr.allocatable)
- || (c->ts.type == BT_DERIVED && !c->attr.pointer
- && c->ts.u.derived->attr.alloc_comp))
- {
- allocatable = true;
- sym->attr.alloc_comp = 1;
- }
-
- /* Look for pointer components. */
- if (c->attr.pointer
- || (c->ts.type == BT_CLASS && c->attr.class_ok
- && CLASS_DATA (c)->attr.class_pointer)
- || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
- {
- pointer = true;
- sym->attr.pointer_comp = 1;
- }
-
- /* Look for procedure pointer components. */
- if (c->attr.proc_pointer
- || (c->ts.type == BT_DERIVED
- && c->ts.u.derived->attr.proc_pointer_comp))
- sym->attr.proc_pointer_comp = 1;
-
- /* Looking for coarray components. */
- if (c->attr.codimension
- || (c->ts.type == BT_CLASS && c->attr.class_ok
- && CLASS_DATA (c)->attr.codimension))
- {
- coarray = true;
- sym->attr.coarray_comp = 1;
- }
-
- if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
- && !c->attr.pointer)
- {
- coarray = true;
- sym->attr.coarray_comp = 1;
- }
-
- /* Looking for lock_type components. */
- if ((c->ts.type == BT_DERIVED
- && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
- && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
- || (c->ts.type == BT_CLASS && c->attr.class_ok
- && CLASS_DATA (c)->ts.u.derived->from_intmod
- == INTMOD_ISO_FORTRAN_ENV
- && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
- == ISOFORTRAN_LOCK_TYPE)
- || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.lock_comp
- && !allocatable && !pointer))
- {
- lock_type = 1;
- lock_comp = c;
- sym->attr.lock_comp = 1;
- }
-
- /* Looking for event_type components. */
- if ((c->ts.type == BT_DERIVED
- && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
- && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
- || (c->ts.type == BT_CLASS && c->attr.class_ok
- && CLASS_DATA (c)->ts.u.derived->from_intmod
- == INTMOD_ISO_FORTRAN_ENV
- && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
- == ISOFORTRAN_EVENT_TYPE)
- || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.event_comp
- && !allocatable && !pointer))
- {
- event_type = 1;
- event_comp = c;
- sym->attr.event_comp = 1;
- }
-
- /* Check for F2008, C1302 - and recall that pointers may not be coarrays
- (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
- unless there are nondirect [allocatable or pointer] components
- involved (cf. 1.3.33.1 and 1.3.33.3). */
-
- if (pointer && !coarray && lock_type)
- gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
- "codimension or be a subcomponent of a coarray, "
- "which is not possible as the component has the "
- "pointer attribute", c->name, &c->loc);
- else if (pointer && !coarray && c->ts.type == BT_DERIVED
- && c->ts.u.derived->attr.lock_comp)
- gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
- "of type LOCK_TYPE, which must have a codimension or be a "
- "subcomponent of a coarray", c->name, &c->loc);
-
- if (lock_type && allocatable && !coarray)
- gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
- "a codimension", c->name, &c->loc);
- else if (lock_type && allocatable && c->ts.type == BT_DERIVED
- && c->ts.u.derived->attr.lock_comp)
- gfc_error ("Allocatable component %s at %L must have a codimension as "
- "it has a noncoarray subcomponent of type LOCK_TYPE",
- c->name, &c->loc);
-
- if (sym->attr.coarray_comp && !coarray && lock_type)
- gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
- "subcomponent of type LOCK_TYPE must have a codimension or "
- "be a subcomponent of a coarray. (Variables of type %s may "
- "not have a codimension as already a coarray "
- "subcomponent exists)", c->name, &c->loc, sym->name);
-
- if (sym->attr.lock_comp && coarray && !lock_type)
- gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
- "subcomponent of type LOCK_TYPE must have a codimension or "
- "be a subcomponent of a coarray. (Variables of type %s may "
- "not have a codimension as %s at %L has a codimension or a "
- "coarray subcomponent)", lock_comp->name, &lock_comp->loc,
- sym->name, c->name, &c->loc);
-
- /* Similarly for EVENT TYPE. */
-
- if (pointer && !coarray && event_type)
- gfc_error ("Component %s at %L of type EVENT_TYPE must have a "
- "codimension or be a subcomponent of a coarray, "
- "which is not possible as the component has the "
- "pointer attribute", c->name, &c->loc);
- else if (pointer && !coarray && c->ts.type == BT_DERIVED
- && c->ts.u.derived->attr.event_comp)
- gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
- "of type EVENT_TYPE, which must have a codimension or be a "
- "subcomponent of a coarray", c->name, &c->loc);
-
- if (event_type && allocatable && !coarray)
- gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have "
- "a codimension", c->name, &c->loc);
- else if (event_type && allocatable && c->ts.type == BT_DERIVED
- && c->ts.u.derived->attr.event_comp)
- gfc_error ("Allocatable component %s at %L must have a codimension as "
- "it has a noncoarray subcomponent of type EVENT_TYPE",
- c->name, &c->loc);
-
- if (sym->attr.coarray_comp && !coarray && event_type)
- gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
- "subcomponent of type EVENT_TYPE must have a codimension or "
- "be a subcomponent of a coarray. (Variables of type %s may "
- "not have a codimension as already a coarray "
- "subcomponent exists)", c->name, &c->loc, sym->name);
-
- if (sym->attr.event_comp && coarray && !event_type)
- gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
- "subcomponent of type EVENT_TYPE must have a codimension or "
- "be a subcomponent of a coarray. (Variables of type %s may "
- "not have a codimension as %s at %L has a codimension or a "
- "coarray subcomponent)", event_comp->name, &event_comp->loc,
- sym->name, c->name, &c->loc);
-
- /* Look for private components. */
- if (sym->component_access == ACCESS_PRIVATE
- || c->attr.access == ACCESS_PRIVATE
- || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
- sym->attr.private_comp = 1;
-
- if (lockp) *lockp = lock_comp;
- if (eventp) *eventp = event_comp;
-}
-
-
-static void parse_struct_map (gfc_statement);
-
-/* Parse a union component definition within a structure definition. */
-
-static void
-parse_union (void)
-{
- int compiling;
- gfc_statement st;
- gfc_state_data s;
- gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
- gfc_symbol *un;
-
- accept_statement(ST_UNION);
- push_state (&s, COMP_UNION, gfc_new_block);
- un = gfc_new_block;
-
- compiling = 1;
-
- while (compiling)
- {
- st = next_statement ();
- /* Only MAP declarations valid within a union. */
- switch (st)
- {
- case ST_NONE:
- unexpected_eof ();
-
- case ST_MAP:
- accept_statement (ST_MAP);
- parse_struct_map (ST_MAP);
- /* Add a component to the union for each map. */
- if (!gfc_add_component (un, gfc_new_block->name, &c))
- {
- gfc_internal_error ("failed to create map component '%s'",
- gfc_new_block->name);
- reject_statement ();
- return;
- }
- c->ts.type = BT_DERIVED;
- c->ts.u.derived = gfc_new_block;
- /* Normally components get their initialization expressions when they
- are created in decl.c (build_struct) so we can look through the
- flat component list for initializers during resolution. Unions and
- maps create components along with their type definitions so we
- have to generate initializers here. */
- c->initializer = gfc_default_initializer (&c->ts);
- break;
-
- case ST_END_UNION:
- compiling = 0;
- accept_statement (ST_END_UNION);
- break;
-
- default:
- unexpected_statement (st);
- break;
- }
- }
-
- for (c = un->components; c; c = c->next)
- check_component (un, c, &lock_comp, &event_comp);
-
- /* Add the union as a component in its parent structure. */
- pop_state ();
- if (!gfc_add_component (gfc_current_block (), un->name, &c))
- {
- gfc_internal_error ("failed to create union component '%s'", un->name);
- reject_statement ();
- return;
- }
- c->ts.type = BT_UNION;
- c->ts.u.derived = un;
- c->initializer = gfc_default_initializer (&c->ts);
-
- un->attr.zero_comp = un->components == NULL;
-}
-
-
-/* Parse a STRUCTURE or MAP. */
-
-static void
-parse_struct_map (gfc_statement block)
-{
- int compiling_type;
- gfc_statement st;
- gfc_state_data s;
- gfc_symbol *sym;
- gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
- gfc_compile_state comp;
- gfc_statement ends;
-
- if (block == ST_STRUCTURE_DECL)
- {
- comp = COMP_STRUCTURE;
- ends = ST_END_STRUCTURE;
- }
- else
- {
- gcc_assert (block == ST_MAP);
- comp = COMP_MAP;
- ends = ST_END_MAP;
- }
-
- accept_statement(block);
- push_state (&s, comp, gfc_new_block);
-
- gfc_new_block->component_access = ACCESS_PUBLIC;
- compiling_type = 1;
-
- while (compiling_type)
- {
- st = next_statement ();
- switch (st)
- {
- case ST_NONE:
- unexpected_eof ();
-
- /* Nested structure declarations will be captured as ST_DATA_DECL. */
- case ST_STRUCTURE_DECL:
- /* Let a more specific error make it to decode_statement(). */
- if (gfc_error_check () == 0)
- gfc_error ("Syntax error in nested structure declaration at %C");
- reject_statement ();
- /* Skip the rest of this statement. */
- gfc_error_recovery ();
- break;
-
- case ST_UNION:
- accept_statement (ST_UNION);
- parse_union ();
- break;
-
- case ST_DATA_DECL:
- /* The data declaration was a nested/ad-hoc STRUCTURE field. */
- accept_statement (ST_DATA_DECL);
- if (gfc_new_block && gfc_new_block != gfc_current_block ()
- && gfc_new_block->attr.flavor == FL_STRUCT)
- parse_struct_map (ST_STRUCTURE_DECL);
- break;
-
- case ST_END_STRUCTURE:
- case ST_END_MAP:
- if (st == ends)
- {
- accept_statement (st);
- compiling_type = 0;
- }
- else
- unexpected_statement (st);
- break;
-
- default:
- unexpected_statement (st);
- break;
- }
- }
-
- /* Validate each component. */
- sym = gfc_current_block ();
- for (c = sym->components; c; c = c->next)
- check_component (sym, c, &lock_comp, &event_comp);
-
- sym->attr.zero_comp = (sym->components == NULL);
-
- /* Allow parse_union to find this structure to add to its list of maps. */
- if (block == ST_MAP)
- gfc_new_block = gfc_current_block ();
-
- pop_state ();
-}
-
-
-/* Parse a derived type. */
-
-static void
-parse_derived (void)
-{
- int compiling_type, seen_private, seen_sequence, seen_component;
- gfc_statement st;
- gfc_state_data s;
- gfc_symbol *sym;
- gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
-
- accept_statement (ST_DERIVED_DECL);
- push_state (&s, COMP_DERIVED, gfc_new_block);
-
- gfc_new_block->component_access = ACCESS_PUBLIC;
- seen_private = 0;
- seen_sequence = 0;
- seen_component = 0;
-
- compiling_type = 1;
-
- while (compiling_type)
- {
- st = next_statement ();
- switch (st)
- {
- case ST_NONE:
- unexpected_eof ();
-
- case ST_DATA_DECL:
- case ST_PROCEDURE:
- accept_statement (st);
- seen_component = 1;
- break;
-
- case ST_FINAL:
- gfc_error ("FINAL declaration at %C must be inside CONTAINS");
- break;
-
- case ST_END_TYPE:
-endType:
- compiling_type = 0;
-
- if (!seen_component)
- gfc_notify_std (GFC_STD_F2003, "Derived type "
- "definition at %C without components");
-
- accept_statement (ST_END_TYPE);
- break;
-
- case ST_PRIVATE:
- if (!gfc_find_state (COMP_MODULE))
- {
- gfc_error ("PRIVATE statement in TYPE at %C must be inside "
- "a MODULE");
- break;
- }
-
- if (seen_component)
- {
- gfc_error ("PRIVATE statement at %C must precede "
- "structure components");
- break;
- }
-
- if (seen_private)
- gfc_error ("Duplicate PRIVATE statement at %C");
-
- s.sym->component_access = ACCESS_PRIVATE;
-
- accept_statement (ST_PRIVATE);
- seen_private = 1;
- break;
-
- case ST_SEQUENCE:
- if (seen_component)
- {
- gfc_error ("SEQUENCE statement at %C must precede "
- "structure components");
- break;
- }
-
- if (gfc_current_block ()->attr.sequence)
- gfc_warning (0, "SEQUENCE attribute at %C already specified in "
- "TYPE statement");
-
- if (seen_sequence)
- {
- gfc_error ("Duplicate SEQUENCE statement at %C");
- }
-
- seen_sequence = 1;
- gfc_add_sequence (&gfc_current_block ()->attr,
- gfc_current_block ()->name, NULL);
- break;
-
- case ST_CONTAINS:
- gfc_notify_std (GFC_STD_F2003,
- "CONTAINS block in derived type"
- " definition at %C");
-
- accept_statement (ST_CONTAINS);
- parse_derived_contains ();
- goto endType;
-
- default:
- unexpected_statement (st);
- break;
- }
- }
-
- /* need to verify that all fields of the derived type are
- * interoperable with C if the type is declared to be bind(c)
- */
- sym = gfc_current_block ();
- for (c = sym->components; c; c = c->next)
- check_component (sym, c, &lock_comp, &event_comp);
-
- if (!seen_component)
- sym->attr.zero_comp = 1;
-
- pop_state ();
-}
-
-
-/* Parse an ENUM. */
-
-static void
-parse_enum (void)
-{
- gfc_statement st;
- int compiling_enum;
- gfc_state_data s;
- int seen_enumerator = 0;
-
- push_state (&s, COMP_ENUM, gfc_new_block);
-
- compiling_enum = 1;
-
- while (compiling_enum)
- {
- st = next_statement ();
- switch (st)
- {
- case ST_NONE:
- unexpected_eof ();
- break;
-
- case ST_ENUMERATOR:
- seen_enumerator = 1;
- accept_statement (st);
- break;
-
- case ST_END_ENUM:
- compiling_enum = 0;
- if (!seen_enumerator)
- gfc_error ("ENUM declaration at %C has no ENUMERATORS");
- accept_statement (st);
- break;
-
- default:
- gfc_free_enum_history ();
- unexpected_statement (st);
- break;
- }
- }
- pop_state ();
-}
-
-
-/* Parse an interface. We must be able to deal with the possibility
- of recursive interfaces. The parse_spec() subroutine is mutually
- recursive with parse_interface(). */
-
-static gfc_statement parse_spec (gfc_statement);
-
-static void
-parse_interface (void)
-{
- gfc_compile_state new_state = COMP_NONE, current_state;
- gfc_symbol *prog_unit, *sym;
- gfc_interface_info save;
- gfc_state_data s1, s2;
- gfc_statement st;
-
- accept_statement (ST_INTERFACE);
-
- current_interface.ns = gfc_current_ns;
- save = current_interface;
-
- sym = (current_interface.type == INTERFACE_GENERIC
- || current_interface.type == INTERFACE_USER_OP)
- ? gfc_new_block : NULL;
-
- push_state (&s1, COMP_INTERFACE, sym);
- current_state = COMP_NONE;
-
-loop:
- gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
-
- st = next_statement ();
- switch (st)
- {
- case ST_NONE:
- unexpected_eof ();
-
- case ST_SUBROUTINE:
- case ST_FUNCTION:
- if (st == ST_SUBROUTINE)
- new_state = COMP_SUBROUTINE;
- else if (st == ST_FUNCTION)
- new_state = COMP_FUNCTION;
- if (gfc_new_block->attr.pointer)
- {
- gfc_new_block->attr.pointer = 0;
- gfc_new_block->attr.proc_pointer = 1;
- }
- if (!gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
- gfc_new_block->formal, NULL))
- {
- reject_statement ();
- gfc_free_namespace (gfc_current_ns);
- goto loop;
- }
- /* F2008 C1210 forbids the IMPORT statement in module procedure
- interface bodies and the flag is set to import symbols. */
- if (gfc_new_block->attr.module_procedure)
- gfc_current_ns->has_import_set = 1;
- break;
-
- case ST_PROCEDURE:
- case ST_MODULE_PROC: /* The module procedure matcher makes
- sure the context is correct. */
- accept_statement (st);
- gfc_free_namespace (gfc_current_ns);
- goto loop;
-
- case ST_END_INTERFACE:
- gfc_free_namespace (gfc_current_ns);
- gfc_current_ns = current_interface.ns;
- goto done;
-
- default:
- gfc_error ("Unexpected %s statement in INTERFACE block at %C",
- gfc_ascii_statement (st));
- reject_statement ();
- gfc_free_namespace (gfc_current_ns);
- goto loop;
- }
-
-
- /* Make sure that the generic name has the right attribute. */
- if (current_interface.type == INTERFACE_GENERIC
- && current_state == COMP_NONE)
- {
- if (new_state == COMP_FUNCTION && sym)
- gfc_add_function (&sym->attr, sym->name, NULL);
- else if (new_state == COMP_SUBROUTINE && sym)
- gfc_add_subroutine (&sym->attr, sym->name, NULL);
-
- current_state = new_state;
- }
-
- if (current_interface.type == INTERFACE_ABSTRACT)
- {
- gfc_add_abstract (&gfc_new_block->attr, &gfc_current_locus);
- if (gfc_is_intrinsic_typename (gfc_new_block->name))
- gfc_error ("Name %qs of ABSTRACT INTERFACE at %C "
- "cannot be the same as an intrinsic type",
- gfc_new_block->name);
- }
-
- push_state (&s2, new_state, gfc_new_block);
- accept_statement (st);
- prog_unit = gfc_new_block;
- prog_unit->formal_ns = gfc_current_ns;
- if (prog_unit == prog_unit->formal_ns->proc_name
- && prog_unit->ns != prog_unit->formal_ns)
- prog_unit->refs++;
-
-decl:
- /* Read data declaration statements. */
- st = parse_spec (ST_NONE);
- in_specification_block = true;
-
- /* Since the interface block does not permit an IMPLICIT statement,
- the default type for the function or the result must be taken
- from the formal namespace. */
- if (new_state == COMP_FUNCTION)
- {
- if (prog_unit->result == prog_unit
- && prog_unit->ts.type == BT_UNKNOWN)
- gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns);
- else if (prog_unit->result != prog_unit
- && prog_unit->result->ts.type == BT_UNKNOWN)
- gfc_set_default_type (prog_unit->result, 1,
- prog_unit->formal_ns);
- }
-
- if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
- {
- gfc_error ("Unexpected %s statement at %C in INTERFACE body",
- gfc_ascii_statement (st));
- reject_statement ();
- goto decl;
- }
-
- /* Add EXTERNAL attribute to function or subroutine. */
- if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy)
- gfc_add_external (&prog_unit->attr, &gfc_current_locus);
-
- current_interface = save;
- gfc_add_interface (prog_unit);
- pop_state ();
-
- if (current_interface.ns
- && current_interface.ns->proc_name
- && strcmp (current_interface.ns->proc_name->name,
- prog_unit->name) == 0)
- gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
- "enclosing procedure", prog_unit->name,
- &current_interface.ns->proc_name->declared_at);
-
- goto loop;
-
-done:
- pop_state ();
-}
-
-
-/* Associate function characteristics by going back to the function
- declaration and rematching the prefix. */
-
-static match
-match_deferred_characteristics (gfc_typespec * ts)
-{
- locus loc;
- match m = MATCH_ERROR;
- char name[GFC_MAX_SYMBOL_LEN + 1];
-
- loc = gfc_current_locus;
-
- gfc_current_locus = gfc_current_block ()->declared_at;
-
- gfc_clear_error ();
- gfc_buffer_error (true);
- m = gfc_match_prefix (ts);
- gfc_buffer_error (false);
-
- if (ts->type == BT_DERIVED)
- {
- ts->kind = 0;
-
- if (!ts->u.derived)
- m = MATCH_ERROR;
- }
-
- /* Only permit one go at the characteristic association. */
- if (ts->kind == -1)
- ts->kind = 0;
-
- /* Set the function locus correctly. If we have not found the
- function name, there is an error. */
- if (m == MATCH_YES
- && gfc_match ("function% %n", name) == MATCH_YES
- && strcmp (name, gfc_current_block ()->name) == 0)
- {
- gfc_current_block ()->declared_at = gfc_current_locus;
- gfc_commit_symbols ();
- }
- else
- {
- gfc_error_check ();
- gfc_undo_symbols ();
- }
-
- gfc_current_locus =loc;
- return m;
-}
-
-
-/* Check specification-expressions in the function result of the currently
- parsed block and ensure they are typed (give an IMPLICIT type if necessary).
- For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
- scope are not yet parsed so this has to be delayed up to parse_spec. */
-
-static void
-check_function_result_typed (void)
-{
- gfc_typespec ts;
-
- gcc_assert (gfc_current_state () == COMP_FUNCTION);
-
- if (!gfc_current_ns->proc_name->result) return;
-
- ts = gfc_current_ns->proc_name->result->ts;
-
- /* Check type-parameters, at the moment only CHARACTER lengths possible. */
- /* TODO: Extend when KIND type parameters are implemented. */
- if (ts.type == BT_CHARACTER && ts.u.cl && ts.u.cl->length)
- gfc_expr_check_typed (ts.u.cl->length, gfc_current_ns, true);
-}
-
-
-/* Parse a set of specification statements. Returns the statement
- that doesn't fit. */
-
-static gfc_statement
-parse_spec (gfc_statement st)
-{
- st_state ss;
- bool function_result_typed = false;
- bool bad_characteristic = false;
- gfc_typespec *ts;
-
- in_specification_block = true;
-
- verify_st_order (&ss, ST_NONE, false);
- if (st == ST_NONE)
- st = next_statement ();
-
- /* If we are not inside a function or don't have a result specified so far,
- do nothing special about it. */
- if (gfc_current_state () != COMP_FUNCTION)
- function_result_typed = true;
- else
- {
- gfc_symbol* proc = gfc_current_ns->proc_name;
- gcc_assert (proc);
-
- if (proc->result->ts.type == BT_UNKNOWN)
- function_result_typed = true;
- }
-
-loop:
-
- /* If we're inside a BLOCK construct, some statements are disallowed.
- Check this here. Attribute declaration statements like INTENT, OPTIONAL
- or VALUE are also disallowed, but they don't have a particular ST_*
- key so we have to check for them individually in their matcher routine. */
- if (gfc_current_state () == COMP_BLOCK)
- switch (st)
- {
- case ST_IMPLICIT:
- case ST_IMPLICIT_NONE:
- case ST_NAMELIST:
- case ST_COMMON:
- case ST_EQUIVALENCE:
- case ST_STATEMENT_FUNCTION:
- gfc_error ("%s statement is not allowed inside of BLOCK at %C",
- gfc_ascii_statement (st));
- reject_statement ();
- break;
-
- default:
- break;
- }
- else if (gfc_current_state () == COMP_BLOCK_DATA)
- /* Fortran 2008, C1116. */
- switch (st)
- {
- case ST_ATTR_DECL:
- case ST_COMMON:
- case ST_DATA:
- case ST_DATA_DECL:
- case ST_DERIVED_DECL:
- case ST_END_BLOCK_DATA:
- case ST_EQUIVALENCE:
- case ST_IMPLICIT:
- case ST_IMPLICIT_NONE:
- case ST_OMP_THREADPRIVATE:
- case ST_PARAMETER:
- case ST_STRUCTURE_DECL:
- case ST_TYPE:
- case ST_USE:
- break;
-
- case ST_NONE:
- break;
-
- default:
- gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
- gfc_ascii_statement (st));
- reject_statement ();
- break;
- }
-
- /* If we find a statement that cannot be followed by an IMPLICIT statement
- (and thus we can expect to see none any further), type the function result
- if it has not yet been typed. Be careful not to give the END statement
- to verify_st_order! */
- if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS)
- {
- bool verify_now = false;
-
- if (st == ST_END_FUNCTION || st == ST_CONTAINS)
- verify_now = true;
- else
- {
- st_state dummyss;
- verify_st_order (&dummyss, ST_NONE, false);
- verify_st_order (&dummyss, st, false);
-
- if (!verify_st_order (&dummyss, ST_IMPLICIT, true))
- verify_now = true;
- }
-
- if (verify_now)
- {
- check_function_result_typed ();
- function_result_typed = true;
- }
- }
-
- switch (st)
- {
- case ST_NONE:
- unexpected_eof ();
-
- case ST_IMPLICIT_NONE:
- case ST_IMPLICIT:
- if (!function_result_typed)
- {
- check_function_result_typed ();
- function_result_typed = true;
- }
- goto declSt;
-
- case ST_FORMAT:
- case ST_ENTRY:
- case ST_DATA: /* Not allowed in interfaces */
- if (gfc_current_state () == COMP_INTERFACE)
- break;
-
- /* Fall through */
-
- case ST_USE:
- case ST_IMPORT:
- case ST_PARAMETER:
- case ST_PUBLIC:
- case ST_PRIVATE:
- case ST_STRUCTURE_DECL:
- case ST_DERIVED_DECL:
- case_decl:
- case_omp_decl:
-declSt:
- if (!verify_st_order (&ss, st, false))
- {
- reject_statement ();
- st = next_statement ();
- goto loop;
- }
-
- switch (st)
- {
- case ST_INTERFACE:
- parse_interface ();
- break;
-
- case ST_STRUCTURE_DECL:
- parse_struct_map (ST_STRUCTURE_DECL);
- break;
-
- case ST_DERIVED_DECL:
- parse_derived ();
- break;
-
- case ST_PUBLIC:
- case ST_PRIVATE:
- if (gfc_current_state () != COMP_MODULE)
- {
- gfc_error ("%s statement must appear in a MODULE",
- gfc_ascii_statement (st));
- reject_statement ();
- break;
- }
-
- if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
- {
- gfc_error ("%s statement at %C follows another accessibility "
- "specification", gfc_ascii_statement (st));
- reject_statement ();
- break;
- }
-
- gfc_current_ns->default_access = (st == ST_PUBLIC)
- ? ACCESS_PUBLIC : ACCESS_PRIVATE;
-
- break;
-
- case ST_STATEMENT_FUNCTION:
- if (gfc_current_state () == COMP_MODULE
- || gfc_current_state () == COMP_SUBMODULE)
- {
- unexpected_statement (st);
- break;
- }
-
- default:
- break;
- }
-
- accept_statement (st);
- st = next_statement ();
- goto loop;
-
- case ST_ENUM:
- accept_statement (st);
- parse_enum();
- st = next_statement ();
- goto loop;
-
- case ST_GET_FCN_CHARACTERISTICS:
- /* This statement triggers the association of a function's result
- characteristics. */
- ts = &gfc_current_block ()->result->ts;
- if (match_deferred_characteristics (ts) != MATCH_YES)
- bad_characteristic = true;
-
- st = next_statement ();
- goto loop;
-
- default:
- break;
- }
-
- /* If match_deferred_characteristics failed, then there is an error. */
- if (bad_characteristic)
- {
- ts = &gfc_current_block ()->result->ts;
- if (ts->type != BT_DERIVED)
- gfc_error ("Bad kind expression for function %qs at %L",
- gfc_current_block ()->name,
- &gfc_current_block ()->declared_at);
- else
- gfc_error ("The type for function %qs at %L is not accessible",
- gfc_current_block ()->name,
- &gfc_current_block ()->declared_at);
-
- gfc_current_block ()->ts.kind = 0;
- /* Keep the derived type; if it's bad, it will be discovered later. */
- if (!(ts->type == BT_DERIVED && ts->u.derived))
- ts->type = BT_UNKNOWN;
- }
-
- in_specification_block = false;
-
- return st;
-}
-
-
-/* Parse a WHERE block, (not a simple WHERE statement). */
-
-static void
-parse_where_block (void)
-{
- int seen_empty_else;
- gfc_code *top, *d;
- gfc_state_data s;
- gfc_statement st;
-
- accept_statement (ST_WHERE_BLOCK);
- top = gfc_state_stack->tail;
-
- push_state (&s, COMP_WHERE, gfc_new_block);
-
- d = add_statement ();
- d->expr1 = top->expr1;
- d->op = EXEC_WHERE;
-
- top->expr1 = NULL;
- top->block = d;
-
- seen_empty_else = 0;
-
- do
- {
- st = next_statement ();
- switch (st)
- {
- case ST_NONE:
- unexpected_eof ();
-
- case ST_WHERE_BLOCK:
- parse_where_block ();
- break;
-
- case ST_ASSIGNMENT:
- case ST_WHERE:
- accept_statement (st);
- break;
-
- case ST_ELSEWHERE:
- if (seen_empty_else)
- {
- gfc_error ("ELSEWHERE statement at %C follows previous "
- "unmasked ELSEWHERE");
- reject_statement ();
- break;
- }
-
- if (new_st.expr1 == NULL)
- seen_empty_else = 1;
-
- d = new_level (gfc_state_stack->head);
- d->op = EXEC_WHERE;
- d->expr1 = new_st.expr1;
-
- accept_statement (st);
-
- break;
-
- case ST_END_WHERE:
- accept_statement (st);
- break;
-
- default:
- gfc_error ("Unexpected %s statement in WHERE block at %C",
- gfc_ascii_statement (st));
- reject_statement ();
- break;
- }
- }
- while (st != ST_END_WHERE);
-
- pop_state ();
-}
-
-
-/* Parse a FORALL block (not a simple FORALL statement). */
-
-static void
-parse_forall_block (void)
-{
- gfc_code *top, *d;
- gfc_state_data s;
- gfc_statement st;
-
- accept_statement (ST_FORALL_BLOCK);
- top = gfc_state_stack->tail;
-
- push_state (&s, COMP_FORALL, gfc_new_block);
-
- d = add_statement ();
- d->op = EXEC_FORALL;
- top->block = d;
-
- do
- {
- st = next_statement ();
- switch (st)
- {
-
- case ST_ASSIGNMENT:
- case ST_POINTER_ASSIGNMENT:
- case ST_WHERE:
- case ST_FORALL:
- accept_statement (st);
- break;
-
- case ST_WHERE_BLOCK:
- parse_where_block ();
- break;
-
- case ST_FORALL_BLOCK:
- parse_forall_block ();
- break;
-
- case ST_END_FORALL:
- accept_statement (st);
- break;
-
- case ST_NONE:
- unexpected_eof ();
-
- default:
- gfc_error ("Unexpected %s statement in FORALL block at %C",
- gfc_ascii_statement (st));
-
- reject_statement ();
- break;
- }
- }
- while (st != ST_END_FORALL);
-
- pop_state ();
-}
-
-
-static gfc_statement parse_executable (gfc_statement);
-
-/* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
-
-static void
-parse_if_block (void)
-{
- gfc_code *top, *d;
- gfc_statement st;
- locus else_locus;
- gfc_state_data s;
- int seen_else;
-
- seen_else = 0;
- accept_statement (ST_IF_BLOCK);
-
- top = gfc_state_stack->tail;
- push_state (&s, COMP_IF, gfc_new_block);
-
- new_st.op = EXEC_IF;
- d = add_statement ();
-
- d->expr1 = top->expr1;
- top->expr1 = NULL;
- top->block = d;
-
- do
- {
- st = parse_executable (ST_NONE);
-
- switch (st)
- {
- case ST_NONE:
- unexpected_eof ();
-
- case ST_ELSEIF:
- if (seen_else)
- {
- gfc_error ("ELSE IF statement at %C cannot follow ELSE "
- "statement at %L", &else_locus);
-
- reject_statement ();
- break;
- }
-
- d = new_level (gfc_state_stack->head);
- d->op = EXEC_IF;
- d->expr1 = new_st.expr1;
-
- accept_statement (st);
-
- break;
-
- case ST_ELSE:
- if (seen_else)
- {
- gfc_error ("Duplicate ELSE statements at %L and %C",
- &else_locus);
- reject_statement ();
- break;
- }
-
- seen_else = 1;
- else_locus = gfc_current_locus;
-
- d = new_level (gfc_state_stack->head);
- d->op = EXEC_IF;
-
- accept_statement (st);
-
- break;
-
- case ST_ENDIF:
- break;
-
- default:
- unexpected_statement (st);
- break;
- }
- }
- while (st != ST_ENDIF);
-
- pop_state ();
- accept_statement (st);
-}
-
-
-/* Parse a SELECT block. */
-
-static void
-parse_select_block (void)
-{
- gfc_statement st;
- gfc_code *cp;
- gfc_state_data s;
-
- accept_statement (ST_SELECT_CASE);
-
- cp = gfc_state_stack->tail;
- push_state (&s, COMP_SELECT, gfc_new_block);
-
- /* Make sure that the next statement is a CASE or END SELECT. */
- for (;;)
- {
- st = next_statement ();
- if (st == ST_NONE)
- unexpected_eof ();
- if (st == ST_END_SELECT)
- {
- /* Empty SELECT CASE is OK. */
- accept_statement (st);
- pop_state ();
- return;
- }
- if (st == ST_CASE)
- break;
-
- gfc_error ("Expected a CASE or END SELECT statement following SELECT "
- "CASE at %C");
-
- reject_statement ();
- }
-
- /* At this point, we've got a nonempty select block. */
- cp = new_level (cp);
- *cp = new_st;
-
- accept_statement (st);
-
- do
- {
- st = parse_executable (ST_NONE);
- switch (st)
- {
- case ST_NONE:
- unexpected_eof ();
-
- case ST_CASE:
- cp = new_level (gfc_state_stack->head);
- *cp = new_st;
- gfc_clear_new_st ();
-
- accept_statement (st);
- /* Fall through */
-
- case ST_END_SELECT:
- break;
-
- /* Can't have an executable statement because of
- parse_executable(). */
- default:
- unexpected_statement (st);
- break;
- }
- }
- while (st != ST_END_SELECT);
-
- pop_state ();
- accept_statement (st);
-}
-
-
-/* Pop the current selector from the SELECT TYPE stack. */
-
-static void
-select_type_pop (void)
-{
- gfc_select_type_stack *old = select_type_stack;
- select_type_stack = old->prev;
- free (old);
-}
-
-
-/* Parse a SELECT TYPE construct (F03:R821). */
-
-static void
-parse_select_type_block (void)
-{
- gfc_statement st;
- gfc_code *cp;
- gfc_state_data s;
-
- gfc_current_ns = new_st.ext.block.ns;
- accept_statement (ST_SELECT_TYPE);
-
- cp = gfc_state_stack->tail;
- push_state (&s, COMP_SELECT_TYPE, gfc_new_block);
-
- /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
- or END SELECT. */
- for (;;)
- {
- st = next_statement ();
- if (st == ST_NONE)
- unexpected_eof ();
- if (st == ST_END_SELECT)
- /* Empty SELECT CASE is OK. */
- goto done;
- if (st == ST_TYPE_IS || st == ST_CLASS_IS)
- break;
-
- gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
- "following SELECT TYPE at %C");
-
- reject_statement ();
- }
-
- /* At this point, we've got a nonempty select block. */
- cp = new_level (cp);
- *cp = new_st;
-
- accept_statement (st);
-
- do
- {
- st = parse_executable (ST_NONE);
- switch (st)
- {
- case ST_NONE:
- unexpected_eof ();
-
- case ST_TYPE_IS:
- case ST_CLASS_IS:
- cp = new_level (gfc_state_stack->head);
- *cp = new_st;
- gfc_clear_new_st ();
-
- accept_statement (st);
- /* Fall through */
-
- case ST_END_SELECT:
- break;
-
- /* Can't have an executable statement because of
- parse_executable(). */
- default:
- unexpected_statement (st);
- break;
- }
- }
- while (st != ST_END_SELECT);
-
-done:
- pop_state ();
- accept_statement (st);
- gfc_current_ns = gfc_current_ns->parent;
- select_type_pop ();
-}
-
-
-/* Parse a SELECT RANK construct. */
-
-static void
-parse_select_rank_block (void)
-{
- gfc_statement st;
- gfc_code *cp;
- gfc_state_data s;
-
- gfc_current_ns = new_st.ext.block.ns;
- accept_statement (ST_SELECT_RANK);
-
- cp = gfc_state_stack->tail;
- push_state (&s, COMP_SELECT_RANK, gfc_new_block);
-
- /* Make sure that the next statement is a RANK IS or RANK DEFAULT. */
- for (;;)
- {
- st = next_statement ();
- if (st == ST_NONE)
- unexpected_eof ();
- if (st == ST_END_SELECT)
- /* Empty SELECT CASE is OK. */
- goto done;
- if (st == ST_RANK)
- break;
-
- gfc_error ("Expected RANK or RANK DEFAULT "
- "following SELECT RANK at %C");
-
- reject_statement ();
- }
-
- /* At this point, we've got a nonempty select block. */
- cp = new_level (cp);
- *cp = new_st;
-
- accept_statement (st);
-
- do
- {
- st = parse_executable (ST_NONE);
- switch (st)
- {
- case ST_NONE:
- unexpected_eof ();
-
- case ST_RANK:
- cp = new_level (gfc_state_stack->head);
- *cp = new_st;
- gfc_clear_new_st ();
-
- accept_statement (st);
- /* Fall through */
-
- case ST_END_SELECT:
- break;
-
- /* Can't have an executable statement because of
- parse_executable(). */
- default:
- unexpected_statement (st);
- break;
- }
- }
- while (st != ST_END_SELECT);
-
-done:
- pop_state ();
- accept_statement (st);
- gfc_current_ns = gfc_current_ns->parent;
- select_type_pop ();
-}
-
-
-/* Given a symbol, make sure it is not an iteration variable for a DO
- statement. This subroutine is called when the symbol is seen in a
- context that causes it to become redefined. If the symbol is an
- iterator, we generate an error message and return nonzero. */
-
-int
-gfc_check_do_variable (gfc_symtree *st)
-{
- gfc_state_data *s;
-
- if (!st)
- return 0;
-
- for (s=gfc_state_stack; s; s = s->previous)
- if (s->do_variable == st)
- {
- gfc_error_now ("Variable %qs at %C cannot be redefined inside "
- "loop beginning at %L", st->name, &s->head->loc);
- return 1;
- }
-
- return 0;
-}
-
-
-/* Checks to see if the current statement label closes an enddo.
- Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
- an error) if it incorrectly closes an ENDDO. */
-
-static int
-check_do_closure (void)
-{
- gfc_state_data *p;
-
- if (gfc_statement_label == NULL)
- return 0;
-
- for (p = gfc_state_stack; p; p = p->previous)
- if (p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
- break;
-
- if (p == NULL)
- return 0; /* No loops to close */
-
- if (p->ext.end_do_label == gfc_statement_label)
- {
- if (p == gfc_state_stack)
- return 1;
-
- gfc_error ("End of nonblock DO statement at %C is within another block");
- return 2;
- }
-
- /* At this point, the label doesn't terminate the innermost loop.
- Make sure it doesn't terminate another one. */
- for (; p; p = p->previous)
- if ((p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
- && p->ext.end_do_label == gfc_statement_label)
- {
- gfc_error ("End of nonblock DO statement at %C is interwoven "
- "with another DO loop");
- return 2;
- }
-
- return 0;
-}
-
-
-/* Parse a series of contained program units. */
-
-static void parse_progunit (gfc_statement);
-
-
-/* Parse a CRITICAL block. */
-
-static void
-parse_critical_block (void)
-{
- gfc_code *top, *d;
- gfc_state_data s, *sd;
- gfc_statement st;
-
- for (sd = gfc_state_stack; sd; sd = sd->previous)
- if (sd->state == COMP_OMP_STRUCTURED_BLOCK)
- gfc_error_now (is_oacc (sd)
- ? G_("CRITICAL block inside of OpenACC region at %C")
- : G_("CRITICAL block inside of OpenMP region at %C"));
-
- s.ext.end_do_label = new_st.label1;
-
- accept_statement (ST_CRITICAL);
- top = gfc_state_stack->tail;
-
- push_state (&s, COMP_CRITICAL, gfc_new_block);
-
- d = add_statement ();
- d->op = EXEC_CRITICAL;
- top->block = d;
-
- do
- {
- st = parse_executable (ST_NONE);
-
- switch (st)
- {
- case ST_NONE:
- unexpected_eof ();
- break;
-
- case ST_END_CRITICAL:
- if (s.ext.end_do_label != NULL
- && s.ext.end_do_label != gfc_statement_label)
- gfc_error_now ("Statement label in END CRITICAL at %C does not "
- "match CRITICAL label");
-
- if (gfc_statement_label != NULL)
- {
- new_st.op = EXEC_NOP;
- add_statement ();
- }
- break;
-
- default:
- unexpected_statement (st);
- break;
- }
- }
- while (st != ST_END_CRITICAL);
-
- pop_state ();
- accept_statement (st);
-}
-
-
-/* Set up the local namespace for a BLOCK construct. */
-
-gfc_namespace*
-gfc_build_block_ns (gfc_namespace *parent_ns)
-{
- gfc_namespace* my_ns;
- static int numblock = 1;
-
- my_ns = gfc_get_namespace (parent_ns, 1);
- my_ns->construct_entities = 1;
-
- /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
- code generation (so it must not be NULL).
- We set its recursive argument if our container procedure is recursive, so
- that local variables are accordingly placed on the stack when it
- will be necessary. */
- if (gfc_new_block)
- my_ns->proc_name = gfc_new_block;
- else
- {
- bool t;
- char buffer[20]; /* Enough to hold "block@2147483648\n". */
-
- snprintf(buffer, sizeof(buffer), "block@%d", numblock++);
- gfc_get_symbol (buffer, my_ns, &my_ns->proc_name);
- t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
- my_ns->proc_name->name, NULL);
- gcc_assert (t);
- gfc_commit_symbol (my_ns->proc_name);
- }
-
- if (parent_ns->proc_name)
- my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
-
- return my_ns;
-}
-
-
-/* Parse a BLOCK construct. */
-
-static void
-parse_block_construct (void)
-{
- gfc_namespace* my_ns;
- gfc_namespace* my_parent;
- gfc_state_data s;
-
- gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C");
-
- my_ns = gfc_build_block_ns (gfc_current_ns);
-
- new_st.op = EXEC_BLOCK;
- new_st.ext.block.ns = my_ns;
- new_st.ext.block.assoc = NULL;
- accept_statement (ST_BLOCK);
-
- push_state (&s, COMP_BLOCK, my_ns->proc_name);
- gfc_current_ns = my_ns;
- my_parent = my_ns->parent;
-
- parse_progunit (ST_NONE);
-
- /* Don't depend on the value of gfc_current_ns; it might have been
- reset if the block had errors and was cleaned up. */
- gfc_current_ns = my_parent;
-
- pop_state ();
-}
-
-
-/* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
- behind the scenes with compiler-generated variables. */
-
-static void
-parse_associate (void)
-{
- gfc_namespace* my_ns;
- gfc_state_data s;
- gfc_statement st;
- gfc_association_list* a;
-
- gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C");
-
- my_ns = gfc_build_block_ns (gfc_current_ns);
-
- new_st.op = EXEC_BLOCK;
- new_st.ext.block.ns = my_ns;
- gcc_assert (new_st.ext.block.assoc);
-
- /* Add all associate-names as BLOCK variables. Creating them is enough
- for now, they'll get their values during trans-* phase. */
- gfc_current_ns = my_ns;
- for (a = new_st.ext.block.assoc; a; a = a->next)
- {
- gfc_symbol* sym;
- gfc_ref *ref;
- gfc_array_ref *array_ref;
-
- if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
- gcc_unreachable ();
-
- sym = a->st->n.sym;
- sym->attr.flavor = FL_VARIABLE;
- sym->assoc = a;
- sym->declared_at = a->where;
- gfc_set_sym_referenced (sym);
-
- /* Initialize the typespec. It is not available in all cases,
- however, as it may only be set on the target during resolution.
- Still, sometimes it helps to have it right now -- especially
- for parsing component references on the associate-name
- in case of association to a derived-type. */
- sym->ts = a->target->ts;
-
- /* Check if the target expression is array valued. This cannot always
- be done by looking at target.rank, because that might not have been
- set yet. Therefore traverse the chain of refs, looking for the last
- array ref and evaluate that. */
- array_ref = NULL;
- for (ref = a->target->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY)
- array_ref = &ref->u.ar;
- if (array_ref || a->target->rank)
- {
- gfc_array_spec *as;
- int dim, rank = 0;
- if (array_ref)
- {
- a->rankguessed = 1;
- /* Count the dimension, that have a non-scalar extend. */
- for (dim = 0; dim < array_ref->dimen; ++dim)
- if (array_ref->dimen_type[dim] != DIMEN_ELEMENT
- && !(array_ref->dimen_type[dim] == DIMEN_UNKNOWN
- && array_ref->end[dim] == NULL
- && array_ref->start[dim] != NULL))
- ++rank;
- }
- else
- rank = a->target->rank;
- /* When the rank is greater than zero then sym will be an array. */
- if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
- {
- if ((!CLASS_DATA (sym)->as && rank != 0)
- || (CLASS_DATA (sym)->as
- && CLASS_DATA (sym)->as->rank != rank))
- {
- /* Don't just (re-)set the attr and as in the sym.ts,
- because this modifies the target's attr and as. Copy the
- data and do a build_class_symbol. */
- symbol_attribute attr = CLASS_DATA (a->target)->attr;
- int corank = gfc_get_corank (a->target);
- gfc_typespec type;
-
- if (rank || corank)
- {
- as = gfc_get_array_spec ();
- as->type = AS_DEFERRED;
- as->rank = rank;
- as->corank = corank;
- attr.dimension = rank ? 1 : 0;
- attr.codimension = corank ? 1 : 0;
- }
- else
- {
- as = NULL;
- attr.dimension = attr.codimension = 0;
- }
- attr.class_ok = 0;
- type = CLASS_DATA (sym)->ts;
- if (!gfc_build_class_symbol (&type,
- &attr, &as))
- gcc_unreachable ();
- sym->ts = type;
- sym->ts.type = BT_CLASS;
- sym->attr.class_ok = 1;
- }
- else
- sym->attr.class_ok = 1;
- }
- else if ((!sym->as && rank != 0)
- || (sym->as && sym->as->rank != rank))
- {
- as = gfc_get_array_spec ();
- as->type = AS_DEFERRED;
- as->rank = rank;
- as->corank = gfc_get_corank (a->target);
- sym->as = as;
- sym->attr.dimension = 1;
- if (as->corank)
- sym->attr.codimension = 1;
- }
- }
- }
-
- accept_statement (ST_ASSOCIATE);
- push_state (&s, COMP_ASSOCIATE, my_ns->proc_name);
-
-loop:
- st = parse_executable (ST_NONE);
- switch (st)
- {
- case ST_NONE:
- unexpected_eof ();
-
- case_end:
- accept_statement (st);
- my_ns->code = gfc_state_stack->head;
- break;
-
- default:
- unexpected_statement (st);
- goto loop;
- }
-
- gfc_current_ns = gfc_current_ns->parent;
- pop_state ();
-}
-
-
-/* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
- handled inside of parse_executable(), because they aren't really
- loop statements. */
-
-static void
-parse_do_block (void)
-{
- gfc_statement st;
- gfc_code *top;
- gfc_state_data s;
- gfc_symtree *stree;
- gfc_exec_op do_op;
-
- do_op = new_st.op;
- s.ext.end_do_label = new_st.label1;
-
- if (new_st.ext.iterator != NULL)
- {
- stree = new_st.ext.iterator->var->symtree;
- if (directive_unroll != -1)
- {
- new_st.ext.iterator->unroll = directive_unroll;
- directive_unroll = -1;
- }
- if (directive_ivdep)
- {
- new_st.ext.iterator->ivdep = directive_ivdep;
- directive_ivdep = false;
- }
- if (directive_vector)
- {
- new_st.ext.iterator->vector = directive_vector;
- directive_vector = false;
- }
- if (directive_novector)
- {
- new_st.ext.iterator->novector = directive_novector;
- directive_novector = false;
- }
- }
- else
- stree = NULL;
-
- accept_statement (ST_DO);
-
- top = gfc_state_stack->tail;
- push_state (&s, do_op == EXEC_DO_CONCURRENT ? COMP_DO_CONCURRENT : COMP_DO,
- gfc_new_block);
-
- s.do_variable = stree;
-
- top->block = new_level (top);
- top->block->op = EXEC_DO;
-
-loop:
- st = parse_executable (ST_NONE);
-
- switch (st)
- {
- case ST_NONE:
- unexpected_eof ();
-
- case ST_ENDDO:
- if (s.ext.end_do_label != NULL
- && s.ext.end_do_label != gfc_statement_label)
- gfc_error_now ("Statement label in ENDDO at %C doesn't match "
- "DO label");
-
- if (gfc_statement_label != NULL)
- {
- new_st.op = EXEC_NOP;
- add_statement ();
- }
- break;
-
- case ST_IMPLIED_ENDDO:
- /* If the do-stmt of this DO construct has a do-construct-name,
- the corresponding end-do must be an end-do-stmt (with a matching
- name, but in that case we must have seen ST_ENDDO first).
- We only complain about this in pedantic mode. */
- if (gfc_current_block () != NULL)
- gfc_error_now ("Named block DO at %L requires matching ENDDO name",
- &gfc_current_block()->declared_at);
-
- break;
-
- default:
- unexpected_statement (st);
- goto loop;
- }
-
- pop_state ();
- accept_statement (st);
-}
-
-
-/* Parse the statements of OpenMP do/parallel do. */
-
-static gfc_statement
-parse_omp_do (gfc_statement omp_st)
-{
- gfc_statement st;
- gfc_code *cp, *np;
- gfc_state_data s;
-
- accept_statement (omp_st);
-
- cp = gfc_state_stack->tail;
- push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
- np = new_level (cp);
- np->op = cp->op;
- np->block = NULL;
-
- for (;;)
- {
- st = next_statement ();
- if (st == ST_NONE)
- unexpected_eof ();
- else if (st == ST_DO)
- break;
- else
- unexpected_statement (st);
- }
-
- parse_do_block ();
- if (gfc_statement_label != NULL
- && gfc_state_stack->previous != NULL
- && gfc_state_stack->previous->state == COMP_DO
- && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
- {
- /* In
- DO 100 I=1,10
- !$OMP DO
- DO J=1,10
- ...
- 100 CONTINUE
- there should be no !$OMP END DO. */
- pop_state ();
- return ST_IMPLIED_ENDDO;
- }
-
- check_do_closure ();
- pop_state ();
-
- st = next_statement ();
- gfc_statement omp_end_st = ST_OMP_END_DO;
- switch (omp_st)
- {
- case ST_OMP_DISTRIBUTE: omp_end_st = ST_OMP_END_DISTRIBUTE; break;
- case ST_OMP_DISTRIBUTE_PARALLEL_DO:
- omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO;
- break;
- case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
- omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD;
- break;
- case ST_OMP_DISTRIBUTE_SIMD:
- omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD;
- break;
- case ST_OMP_DO: omp_end_st = ST_OMP_END_DO; break;
- case ST_OMP_DO_SIMD: omp_end_st = ST_OMP_END_DO_SIMD; break;
- case ST_OMP_LOOP: omp_end_st = ST_OMP_END_LOOP; break;
- case ST_OMP_PARALLEL_DO: omp_end_st = ST_OMP_END_PARALLEL_DO; break;
- case ST_OMP_PARALLEL_DO_SIMD:
- omp_end_st = ST_OMP_END_PARALLEL_DO_SIMD;
- break;
- case ST_OMP_PARALLEL_LOOP:
- omp_end_st = ST_OMP_END_PARALLEL_LOOP;
- break;
- case ST_OMP_SIMD: omp_end_st = ST_OMP_END_SIMD; break;
- case ST_OMP_TARGET_PARALLEL_DO:
- omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO;
- break;
- case ST_OMP_TARGET_PARALLEL_DO_SIMD:
- omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO_SIMD;
- break;
- case ST_OMP_TARGET_PARALLEL_LOOP:
- omp_end_st = ST_OMP_END_TARGET_PARALLEL_LOOP;
- break;
- case ST_OMP_TARGET_SIMD: omp_end_st = ST_OMP_END_TARGET_SIMD; break;
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
- omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE;
- break;
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
- omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
- break;
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
- omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
- break;
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
- omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD;
- break;
- case ST_OMP_TARGET_TEAMS_LOOP:
- omp_end_st = ST_OMP_END_TARGET_TEAMS_LOOP;
- break;
- case ST_OMP_TASKLOOP: omp_end_st = ST_OMP_END_TASKLOOP; break;
- case ST_OMP_TASKLOOP_SIMD: omp_end_st = ST_OMP_END_TASKLOOP_SIMD; break;
- case ST_OMP_MASKED_TASKLOOP: omp_end_st = ST_OMP_END_MASKED_TASKLOOP; break;
- case ST_OMP_MASKED_TASKLOOP_SIMD:
- omp_end_st = ST_OMP_END_MASKED_TASKLOOP_SIMD;
- break;
- case ST_OMP_MASTER_TASKLOOP: omp_end_st = ST_OMP_END_MASTER_TASKLOOP; break;
- case ST_OMP_MASTER_TASKLOOP_SIMD:
- omp_end_st = ST_OMP_END_MASTER_TASKLOOP_SIMD;
- break;
- case ST_OMP_PARALLEL_MASKED_TASKLOOP:
- omp_end_st = ST_OMP_END_PARALLEL_MASKED_TASKLOOP;
- break;
- case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
- omp_end_st = ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD;
- break;
- case ST_OMP_PARALLEL_MASTER_TASKLOOP:
- omp_end_st = ST_OMP_END_PARALLEL_MASTER_TASKLOOP;
- break;
- case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
- omp_end_st = ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD;
- break;
- case ST_OMP_TEAMS_DISTRIBUTE:
- omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE;
- break;
- case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
- omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO;
- break;
- case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
- omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
- break;
- case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
- omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD;
- break;
- case ST_OMP_TEAMS_LOOP:
- omp_end_st = ST_OMP_END_TEAMS_LOOP;
- break;
- default: gcc_unreachable ();
- }
- if (st == omp_end_st)
- {
- if (new_st.op == EXEC_OMP_END_NOWAIT)
- cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
- else
- gcc_assert (new_st.op == EXEC_NOP);
- gfc_clear_new_st ();
- gfc_commit_symbols ();
- gfc_warning_check ();
- st = next_statement ();
- }
- return st;
-}
-
-
-/* Parse the statements of OpenMP atomic directive. */
-
-static gfc_statement
-parse_omp_oacc_atomic (bool omp_p)
-{
- gfc_statement st, st_atomic, st_end_atomic;
- gfc_code *cp, *np;
- gfc_state_data s;
- int count;
-
- if (omp_p)
- {
- st_atomic = ST_OMP_ATOMIC;
- st_end_atomic = ST_OMP_END_ATOMIC;
- }
- else
- {
- st_atomic = ST_OACC_ATOMIC;
- st_end_atomic = ST_OACC_END_ATOMIC;
- }
- accept_statement (st_atomic);
-
- cp = gfc_state_stack->tail;
- push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
- np = new_level (cp);
- np->op = cp->op;
- np->block = NULL;
- np->ext.omp_clauses = cp->ext.omp_clauses;
- cp->ext.omp_clauses = NULL;
- count = 1 + np->ext.omp_clauses->capture;
-
- while (count)
- {
- st = next_statement ();
- if (st == ST_NONE)
- unexpected_eof ();
- else if (np->ext.omp_clauses->compare
- && (st == ST_SIMPLE_IF || st == ST_IF_BLOCK))
- {
- count--;
- if (st == ST_IF_BLOCK)
- {
- parse_if_block ();
- /* With else (or elseif). */
- if (gfc_state_stack->tail->block->block)
- count--;
- }
- accept_statement (st);
- }
- else if (st == ST_ASSIGNMENT
- && (!np->ext.omp_clauses->compare
- || np->ext.omp_clauses->capture))
- {
- accept_statement (st);
- count--;
- }
- else
- unexpected_statement (st);
- }
-
- pop_state ();
-
- st = next_statement ();
- if (st == st_end_atomic)
- {
- gfc_clear_new_st ();
- gfc_commit_symbols ();
- gfc_warning_check ();
- st = next_statement ();
- }
- return st;
-}
-
-
-/* Parse the statements of an OpenACC structured block. */
-
-static void
-parse_oacc_structured_block (gfc_statement acc_st)
-{
- gfc_statement st, acc_end_st;
- gfc_code *cp, *np;
- gfc_state_data s, *sd;
-
- for (sd = gfc_state_stack; sd; sd = sd->previous)
- if (sd->state == COMP_CRITICAL)
- gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
-
- accept_statement (acc_st);
-
- cp = gfc_state_stack->tail;
- push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
- np = new_level (cp);
- np->op = cp->op;
- np->block = NULL;
- switch (acc_st)
- {
- case ST_OACC_PARALLEL:
- acc_end_st = ST_OACC_END_PARALLEL;
- break;
- case ST_OACC_KERNELS:
- acc_end_st = ST_OACC_END_KERNELS;
- break;
- case ST_OACC_SERIAL:
- acc_end_st = ST_OACC_END_SERIAL;
- break;
- case ST_OACC_DATA:
- acc_end_st = ST_OACC_END_DATA;
- break;
- case ST_OACC_HOST_DATA:
- acc_end_st = ST_OACC_END_HOST_DATA;
- break;
- default:
- gcc_unreachable ();
- }
-
- do
- {
- st = parse_executable (ST_NONE);
- if (st == ST_NONE)
- unexpected_eof ();
- else if (st != acc_end_st)
- {
- gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st));
- reject_statement ();
- }
- }
- while (st != acc_end_st);
-
- gcc_assert (new_st.op == EXEC_NOP);
-
- gfc_clear_new_st ();
- gfc_commit_symbols ();
- gfc_warning_check ();
- pop_state ();
-}
-
-/* Parse the statements of OpenACC 'loop', or combined compute 'loop'. */
-
-static gfc_statement
-parse_oacc_loop (gfc_statement acc_st)
-{
- gfc_statement st;
- gfc_code *cp, *np;
- gfc_state_data s, *sd;
-
- for (sd = gfc_state_stack; sd; sd = sd->previous)
- if (sd->state == COMP_CRITICAL)
- gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
-
- accept_statement (acc_st);
-
- cp = gfc_state_stack->tail;
- push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
- np = new_level (cp);
- np->op = cp->op;
- np->block = NULL;
-
- for (;;)
- {
- st = next_statement ();
- if (st == ST_NONE)
- unexpected_eof ();
- else if (st == ST_DO)
- break;
- else
- {
- gfc_error ("Expected DO loop at %C");
- reject_statement ();
- }
- }
-
- parse_do_block ();
- if (gfc_statement_label != NULL
- && gfc_state_stack->previous != NULL
- && gfc_state_stack->previous->state == COMP_DO
- && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
- {
- pop_state ();
- return ST_IMPLIED_ENDDO;
- }
-
- check_do_closure ();
- pop_state ();
-
- st = next_statement ();
- if (st == ST_OACC_END_LOOP)
- gfc_warning (0, "Redundant !$ACC END LOOP at %C");
- if ((acc_st == ST_OACC_PARALLEL_LOOP && st == ST_OACC_END_PARALLEL_LOOP) ||
- (acc_st == ST_OACC_KERNELS_LOOP && st == ST_OACC_END_KERNELS_LOOP) ||
- (acc_st == ST_OACC_SERIAL_LOOP && st == ST_OACC_END_SERIAL_LOOP) ||
- (acc_st == ST_OACC_LOOP && st == ST_OACC_END_LOOP))
- {
- gcc_assert (new_st.op == EXEC_NOP);
- gfc_clear_new_st ();
- gfc_commit_symbols ();
- gfc_warning_check ();
- st = next_statement ();
- }
- return st;
-}
-
-
-/* Parse the statements of an OpenMP structured block. */
-
-static gfc_statement
-parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
-{
- gfc_statement st, omp_end_st;
- gfc_code *cp, *np;
- gfc_state_data s;
-
- accept_statement (omp_st);
-
- cp = gfc_state_stack->tail;
- push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
- np = new_level (cp);
- np->op = cp->op;
- np->block = NULL;
-
- switch (omp_st)
- {
- case ST_OMP_PARALLEL:
- omp_end_st = ST_OMP_END_PARALLEL;
- break;
- case ST_OMP_PARALLEL_MASKED:
- omp_end_st = ST_OMP_END_PARALLEL_MASKED;
- break;
- case ST_OMP_PARALLEL_MASTER:
- omp_end_st = ST_OMP_END_PARALLEL_MASTER;
- break;
- case ST_OMP_PARALLEL_SECTIONS:
- omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
- break;
- case ST_OMP_SCOPE:
- omp_end_st = ST_OMP_END_SCOPE;
- break;
- case ST_OMP_SECTIONS:
- omp_end_st = ST_OMP_END_SECTIONS;
- break;
- case ST_OMP_ORDERED:
- omp_end_st = ST_OMP_END_ORDERED;
- break;
- case ST_OMP_CRITICAL:
- omp_end_st = ST_OMP_END_CRITICAL;
- break;
- case ST_OMP_MASKED:
- omp_end_st = ST_OMP_END_MASKED;
- break;
- case ST_OMP_MASTER:
- omp_end_st = ST_OMP_END_MASTER;
- break;
- case ST_OMP_SINGLE:
- omp_end_st = ST_OMP_END_SINGLE;
- break;
- case ST_OMP_TARGET:
- omp_end_st = ST_OMP_END_TARGET;
- break;
- case ST_OMP_TARGET_DATA:
- omp_end_st = ST_OMP_END_TARGET_DATA;
- break;
- case ST_OMP_TARGET_PARALLEL:
- omp_end_st = ST_OMP_END_TARGET_PARALLEL;
- break;
- case ST_OMP_TARGET_TEAMS:
- omp_end_st = ST_OMP_END_TARGET_TEAMS;
- break;
- case ST_OMP_TASK:
- omp_end_st = ST_OMP_END_TASK;
- break;
- case ST_OMP_TASKGROUP:
- omp_end_st = ST_OMP_END_TASKGROUP;
- break;
- case ST_OMP_TEAMS:
- omp_end_st = ST_OMP_END_TEAMS;
- break;
- case ST_OMP_TEAMS_DISTRIBUTE:
- omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE;
- break;
- case ST_OMP_DISTRIBUTE:
- omp_end_st = ST_OMP_END_DISTRIBUTE;
- break;
- case ST_OMP_WORKSHARE:
- omp_end_st = ST_OMP_END_WORKSHARE;
- break;
- case ST_OMP_PARALLEL_WORKSHARE:
- omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
- break;
- default:
- gcc_unreachable ();
- }
-
- bool block_construct = false;
- gfc_namespace *my_ns = NULL;
- gfc_namespace *my_parent = NULL;
-
- st = next_statement ();
-
- if (st == ST_BLOCK)
- {
- /* Adjust state to a strictly-structured block, now that we found that
- the body starts with a BLOCK construct. */
- s.state = COMP_OMP_STRICTLY_STRUCTURED_BLOCK;
-
- block_construct = true;
- gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C");
-
- my_ns = gfc_build_block_ns (gfc_current_ns);
- gfc_current_ns = my_ns;
- my_parent = my_ns->parent;
-
- new_st.op = EXEC_BLOCK;
- new_st.ext.block.ns = my_ns;
- new_st.ext.block.assoc = NULL;
- accept_statement (ST_BLOCK);
- st = parse_spec (ST_NONE);
- }
-
- do
- {
- if (workshare_stmts_only)
- {
- /* Inside of !$omp workshare, only
- scalar assignments
- array assignments
- where statements and constructs
- forall statements and constructs
- !$omp atomic
- !$omp critical
- !$omp parallel
- are allowed. For !$omp critical these
- restrictions apply recursively. */
- bool cycle = true;
-
- for (;;)
- {
- switch (st)
- {
- case ST_NONE:
- unexpected_eof ();
-
- case ST_ASSIGNMENT:
- case ST_WHERE:
- case ST_FORALL:
- accept_statement (st);
- break;
-
- case ST_WHERE_BLOCK:
- parse_where_block ();
- break;
-
- case ST_FORALL_BLOCK:
- parse_forall_block ();
- break;
-
- case ST_OMP_PARALLEL:
- case ST_OMP_PARALLEL_MASKED:
- case ST_OMP_PARALLEL_MASTER:
- case ST_OMP_PARALLEL_SECTIONS:
- st = parse_omp_structured_block (st, false);
- continue;
-
- case ST_OMP_PARALLEL_WORKSHARE:
- case ST_OMP_CRITICAL:
- st = parse_omp_structured_block (st, true);
- continue;
-
- case ST_OMP_PARALLEL_DO:
- case ST_OMP_PARALLEL_DO_SIMD:
- st = parse_omp_do (st);
- continue;
-
- case ST_OMP_ATOMIC:
- st = parse_omp_oacc_atomic (true);
- continue;
-
- default:
- cycle = false;
- break;
- }
-
- if (!cycle)
- break;
-
- st = next_statement ();
- }
- }
- else
- st = parse_executable (st);
- if (st == ST_NONE)
- unexpected_eof ();
- else if (st == ST_OMP_SECTION
- && (omp_st == ST_OMP_SECTIONS
- || omp_st == ST_OMP_PARALLEL_SECTIONS))
- {
- np = new_level (np);
- np->op = cp->op;
- np->block = NULL;
- st = next_statement ();
- }
- else if (block_construct && st == ST_END_BLOCK)
- {
- accept_statement (st);
- gfc_current_ns = my_parent;
- pop_state ();
-
- st = next_statement ();
- if (st == omp_end_st)
- {
- accept_statement (st);
- st = next_statement ();
- }
- return st;
- }
- else if (st != omp_end_st)
- {
- unexpected_statement (st);
- st = next_statement ();
- }
- }
- while (st != omp_end_st);
-
- switch (new_st.op)
- {
- case EXEC_OMP_END_NOWAIT:
- cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
- break;
- case EXEC_OMP_END_CRITICAL:
- if (((cp->ext.omp_clauses->critical_name == NULL)
- ^ (new_st.ext.omp_name == NULL))
- || (new_st.ext.omp_name != NULL
- && strcmp (cp->ext.omp_clauses->critical_name,
- new_st.ext.omp_name) != 0))
- gfc_error ("Name after !$omp critical and !$omp end critical does "
- "not match at %C");
- free (CONST_CAST (char *, new_st.ext.omp_name));
- new_st.ext.omp_name = NULL;
- break;
- case EXEC_OMP_END_SINGLE:
- cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
- = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
- new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
- gfc_free_omp_clauses (new_st.ext.omp_clauses);
- break;
- case EXEC_NOP:
- break;
- default:
- gcc_unreachable ();
- }
-
- gfc_clear_new_st ();
- gfc_commit_symbols ();
- gfc_warning_check ();
- pop_state ();
- st = next_statement ();
- return st;
-}
-
-
-/* Accept a series of executable statements. We return the first
- statement that doesn't fit to the caller. Any block statements are
- passed on to the correct handler, which usually passes the buck
- right back here. */
-
-static gfc_statement
-parse_executable (gfc_statement st)
-{
- int close_flag;
-
- if (st == ST_NONE)
- st = next_statement ();
-
- for (;;)
- {
- close_flag = check_do_closure ();
- if (close_flag)
- switch (st)
- {
- case ST_GOTO:
- case ST_END_PROGRAM:
- case ST_RETURN:
- case ST_EXIT:
- case ST_END_FUNCTION:
- case ST_CYCLE:
- case ST_PAUSE:
- case ST_STOP:
- case ST_ERROR_STOP:
- case ST_END_SUBROUTINE:
-
- case ST_DO:
- case ST_FORALL:
- case ST_WHERE:
- case ST_SELECT_CASE:
- gfc_error ("%s statement at %C cannot terminate a non-block "
- "DO loop", gfc_ascii_statement (st));
- break;
-
- default:
- break;
- }
-
- switch (st)
- {
- case ST_NONE:
- unexpected_eof ();
-
- case ST_DATA:
- gfc_notify_std (GFC_STD_F95_OBS, "DATA statement at %C after the "
- "first executable statement");
- /* Fall through. */
-
- case ST_FORMAT:
- case ST_ENTRY:
- case_executable:
- accept_statement (st);
- if (close_flag == 1)
- return ST_IMPLIED_ENDDO;
- break;
-
- case ST_BLOCK:
- parse_block_construct ();
- break;
-
- case ST_ASSOCIATE:
- parse_associate ();
- break;
-
- case ST_IF_BLOCK:
- parse_if_block ();
- break;
-
- case ST_SELECT_CASE:
- parse_select_block ();
- break;
-
- case ST_SELECT_TYPE:
- parse_select_type_block ();
- break;
-
- case ST_SELECT_RANK:
- parse_select_rank_block ();
- break;
-
- case ST_DO:
- parse_do_block ();
- if (check_do_closure () == 1)
- return ST_IMPLIED_ENDDO;
- break;
-
- case ST_CRITICAL:
- parse_critical_block ();
- break;
-
- case ST_WHERE_BLOCK:
- parse_where_block ();
- break;
-
- case ST_FORALL_BLOCK:
- parse_forall_block ();
- break;
-
- case ST_OACC_PARALLEL_LOOP:
- case ST_OACC_KERNELS_LOOP:
- case ST_OACC_SERIAL_LOOP:
- case ST_OACC_LOOP:
- st = parse_oacc_loop (st);
- if (st == ST_IMPLIED_ENDDO)
- return st;
- continue;
-
- case ST_OACC_PARALLEL:
- case ST_OACC_KERNELS:
- case ST_OACC_SERIAL:
- case ST_OACC_DATA:
- case ST_OACC_HOST_DATA:
- parse_oacc_structured_block (st);
- break;
-
- case ST_OMP_PARALLEL:
- case ST_OMP_PARALLEL_MASKED:
- case ST_OMP_PARALLEL_MASTER:
- case ST_OMP_PARALLEL_SECTIONS:
- case ST_OMP_ORDERED:
- case ST_OMP_CRITICAL:
- case ST_OMP_MASKED:
- case ST_OMP_MASTER:
- case ST_OMP_SCOPE:
- case ST_OMP_SECTIONS:
- case ST_OMP_SINGLE:
- case ST_OMP_TARGET:
- case ST_OMP_TARGET_DATA:
- case ST_OMP_TARGET_PARALLEL:
- case ST_OMP_TARGET_TEAMS:
- case ST_OMP_TEAMS:
- case ST_OMP_TASK:
- case ST_OMP_TASKGROUP:
- st = parse_omp_structured_block (st, false);
- continue;
-
- case ST_OMP_WORKSHARE:
- case ST_OMP_PARALLEL_WORKSHARE:
- st = parse_omp_structured_block (st, true);
- continue;
-
- case ST_OMP_DISTRIBUTE:
- case ST_OMP_DISTRIBUTE_PARALLEL_DO:
- case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
- case ST_OMP_DISTRIBUTE_SIMD:
- case ST_OMP_DO:
- case ST_OMP_DO_SIMD:
- case ST_OMP_LOOP:
- case ST_OMP_PARALLEL_DO:
- case ST_OMP_PARALLEL_DO_SIMD:
- case ST_OMP_PARALLEL_LOOP:
- case ST_OMP_PARALLEL_MASKED_TASKLOOP:
- case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
- case ST_OMP_PARALLEL_MASTER_TASKLOOP:
- case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
- case ST_OMP_MASKED_TASKLOOP:
- case ST_OMP_MASKED_TASKLOOP_SIMD:
- case ST_OMP_MASTER_TASKLOOP:
- case ST_OMP_MASTER_TASKLOOP_SIMD:
- case ST_OMP_SIMD:
- case ST_OMP_TARGET_PARALLEL_DO:
- case ST_OMP_TARGET_PARALLEL_DO_SIMD:
- case ST_OMP_TARGET_PARALLEL_LOOP:
- case ST_OMP_TARGET_SIMD:
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
- case ST_OMP_TARGET_TEAMS_LOOP:
- case ST_OMP_TASKLOOP:
- case ST_OMP_TASKLOOP_SIMD:
- case ST_OMP_TEAMS_DISTRIBUTE:
- case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
- case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
- case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
- case ST_OMP_TEAMS_LOOP:
- st = parse_omp_do (st);
- if (st == ST_IMPLIED_ENDDO)
- return st;
- continue;
-
- case ST_OACC_ATOMIC:
- st = parse_omp_oacc_atomic (false);
- continue;
-
- case ST_OMP_ATOMIC:
- st = parse_omp_oacc_atomic (true);
- continue;
-
- default:
- return st;
- }
-
- if (directive_unroll != -1)
- gfc_error ("%<GCC unroll%> directive not at the start of a loop at %C");
-
- if (directive_ivdep)
- gfc_error ("%<GCC ivdep%> directive not at the start of a loop at %C");
-
- if (directive_vector)
- gfc_error ("%<GCC vector%> directive not at the start of a loop at %C");
-
- if (directive_novector)
- gfc_error ("%<GCC novector%> "
- "directive not at the start of a loop at %C");
-
- st = next_statement ();
- }
-}
-
-
-/* Fix the symbols for sibling functions. These are incorrectly added to
- the child namespace as the parser didn't know about this procedure. */
-
-static void
-gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
-{
- gfc_namespace *ns;
- gfc_symtree *st;
- gfc_symbol *old_sym;
-
- for (ns = siblings; ns; ns = ns->sibling)
- {
- st = gfc_find_symtree (ns->sym_root, sym->name);
-
- if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
- goto fixup_contained;
-
- if ((st->n.sym->attr.flavor == FL_DERIVED
- && sym->attr.generic && sym->attr.function)
- ||(sym->attr.flavor == FL_DERIVED
- && st->n.sym->attr.generic && st->n.sym->attr.function))
- goto fixup_contained;
-
- old_sym = st->n.sym;
- if (old_sym->ns == ns
- && !old_sym->attr.contained
-
- /* By 14.6.1.3, host association should be excluded
- for the following. */
- && !(old_sym->attr.external
- || (old_sym->ts.type != BT_UNKNOWN
- && !old_sym->attr.implicit_type)
- || old_sym->attr.flavor == FL_PARAMETER
- || old_sym->attr.use_assoc
- || old_sym->attr.in_common
- || old_sym->attr.in_equivalence
- || old_sym->attr.data
- || old_sym->attr.dummy
- || old_sym->attr.result
- || old_sym->attr.dimension
- || old_sym->attr.allocatable
- || old_sym->attr.intrinsic
- || old_sym->attr.generic
- || old_sym->attr.flavor == FL_NAMELIST
- || old_sym->attr.flavor == FL_LABEL
- || old_sym->attr.proc == PROC_ST_FUNCTION))
- {
- /* Replace it with the symbol from the parent namespace. */
- st->n.sym = sym;
- sym->refs++;
-
- gfc_release_symbol (old_sym);
- }
-
-fixup_contained:
- /* Do the same for any contained procedures. */
- gfc_fixup_sibling_symbols (sym, ns->contained);
- }
-}
-
-static void
-parse_contained (int module)
-{
- gfc_namespace *ns, *parent_ns, *tmp;
- gfc_state_data s1, s2;
- gfc_statement st;
- gfc_symbol *sym;
- gfc_entry_list *el;
- locus old_loc;
- int contains_statements = 0;
- int seen_error = 0;
-
- push_state (&s1, COMP_CONTAINS, NULL);
- parent_ns = gfc_current_ns;
-
- do
- {
- gfc_current_ns = gfc_get_namespace (parent_ns, 1);
-
- gfc_current_ns->sibling = parent_ns->contained;
- parent_ns->contained = gfc_current_ns;
-
- next:
- /* Process the next available statement. We come here if we got an error
- and rejected the last statement. */
- old_loc = gfc_current_locus;
- st = next_statement ();
-
- switch (st)
- {
- case ST_NONE:
- unexpected_eof ();
-
- case ST_FUNCTION:
- case ST_SUBROUTINE:
- contains_statements = 1;
- accept_statement (st);
-
- push_state (&s2,
- (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
- gfc_new_block);
-
- /* For internal procedures, create/update the symbol in the
- parent namespace. */
-
- if (!module)
- {
- if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
- gfc_error ("Contained procedure %qs at %C is already "
- "ambiguous", gfc_new_block->name);
- else
- {
- if (gfc_add_procedure (&sym->attr, PROC_INTERNAL,
- sym->name,
- &gfc_new_block->declared_at))
- {
- if (st == ST_FUNCTION)
- gfc_add_function (&sym->attr, sym->name,
- &gfc_new_block->declared_at);
- else
- gfc_add_subroutine (&sym->attr, sym->name,
- &gfc_new_block->declared_at);
- }
- }
-
- gfc_commit_symbols ();
- }
- else
- sym = gfc_new_block;
-
- /* Mark this as a contained function, so it isn't replaced
- by other module functions. */
- sym->attr.contained = 1;
-
- /* Set implicit_pure so that it can be reset if any of the
- tests for purity fail. This is used for some optimisation
- during translation. */
- if (!sym->attr.pure)
- sym->attr.implicit_pure = 1;
-
- parse_progunit (ST_NONE);
-
- /* Fix up any sibling functions that refer to this one. */
- gfc_fixup_sibling_symbols (sym, gfc_current_ns);
- /* Or refer to any of its alternate entry points. */
- for (el = gfc_current_ns->entries; el; el = el->next)
- gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
-
- gfc_current_ns->code = s2.head;
- gfc_current_ns = parent_ns;
-
- pop_state ();
- break;
-
- /* These statements are associated with the end of the host unit. */
- case ST_END_FUNCTION:
- case ST_END_MODULE:
- case ST_END_SUBMODULE:
- case ST_END_PROGRAM:
- case ST_END_SUBROUTINE:
- accept_statement (st);
- gfc_current_ns->code = s1.head;
- break;
-
- default:
- gfc_error ("Unexpected %s statement in CONTAINS section at %C",
- gfc_ascii_statement (st));
- reject_statement ();
- seen_error = 1;
- goto next;
- break;
- }
- }
- while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
- && st != ST_END_MODULE && st != ST_END_SUBMODULE
- && st != ST_END_PROGRAM);
-
- /* The first namespace in the list is guaranteed to not have
- anything (worthwhile) in it. */
- tmp = gfc_current_ns;
- gfc_current_ns = parent_ns;
- if (seen_error && tmp->refs > 1)
- gfc_free_namespace (tmp);
-
- ns = gfc_current_ns->contained;
- gfc_current_ns->contained = ns->sibling;
- gfc_free_namespace (ns);
-
- pop_state ();
- if (!contains_statements)
- gfc_notify_std (GFC_STD_F2008, "CONTAINS statement without "
- "FUNCTION or SUBROUTINE statement at %L", &old_loc);
-}
-
-
-/* The result variable in a MODULE PROCEDURE needs to be created and
- its characteristics copied from the interface since it is neither
- declared in the procedure declaration nor in the specification
- part. */
-
-static void
-get_modproc_result (void)
-{
- gfc_symbol *proc;
- if (gfc_state_stack->previous
- && gfc_state_stack->previous->state == COMP_CONTAINS
- && gfc_state_stack->previous->previous->state == COMP_SUBMODULE)
- {
- proc = gfc_current_ns->proc_name ? gfc_current_ns->proc_name : NULL;
- if (proc != NULL
- && proc->attr.function
- && proc->tlink
- && proc->tlink->result
- && proc->tlink->result != proc->tlink)
- {
- gfc_copy_dummy_sym (&proc->result, proc->tlink->result, 1);
- gfc_set_sym_referenced (proc->result);
- proc->result->attr.if_source = IFSRC_DECL;
- gfc_commit_symbol (proc->result);
- }
- }
-}
-
-
-/* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
-
-static void
-parse_progunit (gfc_statement st)
-{
- gfc_state_data *p;
- int n;
-
- gfc_adjust_builtins ();
-
- if (gfc_new_block
- && gfc_new_block->abr_modproc_decl
- && gfc_new_block->attr.function)
- get_modproc_result ();
-
- st = parse_spec (st);
- switch (st)
- {
- case ST_NONE:
- unexpected_eof ();
-
- case ST_CONTAINS:
- /* This is not allowed within BLOCK! */
- if (gfc_current_state () != COMP_BLOCK)
- goto contains;
- break;
-
- case_end:
- accept_statement (st);
- goto done;
-
- default:
- break;
- }
-
- if (gfc_current_state () == COMP_FUNCTION)
- gfc_check_function_type (gfc_current_ns);
-
-loop:
- for (;;)
- {
- st = parse_executable (st);
-
- switch (st)
- {
- case ST_NONE:
- unexpected_eof ();
-
- case ST_CONTAINS:
- /* This is not allowed within BLOCK! */
- if (gfc_current_state () != COMP_BLOCK)
- goto contains;
- break;
-
- case_end:
- accept_statement (st);
- goto done;
-
- default:
- break;
- }
-
- unexpected_statement (st);
- reject_statement ();
- st = next_statement ();
- }
-
-contains:
- n = 0;
-
- for (p = gfc_state_stack; p; p = p->previous)
- if (p->state == COMP_CONTAINS)
- n++;
-
- if (gfc_find_state (COMP_MODULE) == true
- || gfc_find_state (COMP_SUBMODULE) == true)
- n--;
-
- if (n > 0)
- {
- gfc_error ("CONTAINS statement at %C is already in a contained "
- "program unit");
- reject_statement ();
- st = next_statement ();
- goto loop;
- }
-
- parse_contained (0);
-
-done:
- gfc_current_ns->code = gfc_state_stack->head;
-}
-
-
-/* Come here to complain about a global symbol already in use as
- something else. */
-
-void
-gfc_global_used (gfc_gsymbol *sym, locus *where)
-{
- const char *name;
-
- if (where == NULL)
- where = &gfc_current_locus;
-
- switch(sym->type)
- {
- case GSYM_PROGRAM:
- name = "PROGRAM";
- break;
- case GSYM_FUNCTION:
- name = "FUNCTION";
- break;
- case GSYM_SUBROUTINE:
- name = "SUBROUTINE";
- break;
- case GSYM_COMMON:
- name = "COMMON";
- break;
- case GSYM_BLOCK_DATA:
- name = "BLOCK DATA";
- break;
- case GSYM_MODULE:
- name = "MODULE";
- break;
- default:
- name = NULL;
- }
-
- if (name)
- {
- if (sym->binding_label)
- gfc_error ("Global binding name %qs at %L is already being used "
- "as a %s at %L", sym->binding_label, where, name,
- &sym->where);
- else
- gfc_error ("Global name %qs at %L is already being used as "
- "a %s at %L", sym->name, where, name, &sym->where);
- }
- else
- {
- if (sym->binding_label)
- gfc_error ("Global binding name %qs at %L is already being used "
- "at %L", sym->binding_label, where, &sym->where);
- else
- gfc_error ("Global name %qs at %L is already being used at %L",
- sym->name, where, &sym->where);
- }
-}
-
-
-/* Parse a block data program unit. */
-
-static void
-parse_block_data (void)
-{
- gfc_statement st;
- static locus blank_locus;
- static int blank_block=0;
- gfc_gsymbol *s;
-
- gfc_current_ns->proc_name = gfc_new_block;
- gfc_current_ns->is_block_data = 1;
-
- if (gfc_new_block == NULL)
- {
- if (blank_block)
- gfc_error ("Blank BLOCK DATA at %C conflicts with "
- "prior BLOCK DATA at %L", &blank_locus);
- else
- {
- blank_block = 1;
- blank_locus = gfc_current_locus;
- }
- }
- else
- {
- s = gfc_get_gsymbol (gfc_new_block->name, false);
- if (s->defined
- || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
- gfc_global_used (s, &gfc_new_block->declared_at);
- else
- {
- s->type = GSYM_BLOCK_DATA;
- s->where = gfc_new_block->declared_at;
- s->defined = 1;
- }
- }
-
- st = parse_spec (ST_NONE);
-
- while (st != ST_END_BLOCK_DATA)
- {
- gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
- gfc_ascii_statement (st));
- reject_statement ();
- st = next_statement ();
- }
-}
-
-
-/* Following the association of the ancestor (sub)module symbols, they
- must be set host rather than use associated and all must be public.
- They are flagged up by 'used_in_submodule' so that they can be set
- DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl). Otherwise the
- linker chokes on multiple symbol definitions. */
-
-static void
-set_syms_host_assoc (gfc_symbol *sym)
-{
- gfc_component *c;
- const char dot[2] = ".";
- /* Symbols take the form module.submodule_ or module.name_. */
- char parent1[2 * GFC_MAX_SYMBOL_LEN + 2];
- char parent2[2 * GFC_MAX_SYMBOL_LEN + 2];
-
- if (sym == NULL)
- return;
-
- if (sym->attr.module_procedure)
- sym->attr.external = 0;
-
- sym->attr.use_assoc = 0;
- sym->attr.host_assoc = 1;
- sym->attr.used_in_submodule =1;
-
- if (sym->attr.flavor == FL_DERIVED)
- {
- /* Derived types with PRIVATE components that are declared in
- modules other than the parent module must not be changed to be
- PUBLIC. The 'use-assoc' attribute must be reset so that the
- test in symbol.c(gfc_find_component) works correctly. This is
- not necessary for PRIVATE symbols since they are not read from
- the module. */
- memset(parent1, '\0', sizeof(parent1));
- memset(parent2, '\0', sizeof(parent2));
- strcpy (parent1, gfc_new_block->name);
- strcpy (parent2, sym->module);
- if (strcmp (strtok (parent1, dot), strtok (parent2, dot)) == 0)
- {
- for (c = sym->components; c; c = c->next)
- c->attr.access = ACCESS_PUBLIC;
- }
- else
- {
- sym->attr.use_assoc = 1;
- sym->attr.host_assoc = 0;
- }
- }
-}
-
-/* Parse a module subprogram. */
-
-static void
-parse_module (void)
-{
- gfc_statement st;
- gfc_gsymbol *s;
- bool error;
-
- s = gfc_get_gsymbol (gfc_new_block->name, false);
- if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
- gfc_global_used (s, &gfc_new_block->declared_at);
- else
- {
- s->type = GSYM_MODULE;
- s->where = gfc_new_block->declared_at;
- s->defined = 1;
- }
-
- /* Something is nulling the module_list after this point. This is good
- since it allows us to 'USE' the parent modules that the submodule
- inherits and to set (most) of the symbols as host associated. */
- if (gfc_current_state () == COMP_SUBMODULE)
- {
- use_modules ();
- gfc_traverse_ns (gfc_current_ns, set_syms_host_assoc);
- }
-
- st = parse_spec (ST_NONE);
-
- error = false;
-loop:
- switch (st)
- {
- case ST_NONE:
- unexpected_eof ();
-
- case ST_CONTAINS:
- parse_contained (1);
- break;
-
- case ST_END_MODULE:
- case ST_END_SUBMODULE:
- accept_statement (st);
- break;
-
- default:
- gfc_error ("Unexpected %s statement in MODULE at %C",
- gfc_ascii_statement (st));
-
- error = true;
- reject_statement ();
- st = next_statement ();
- goto loop;
- }
-
- /* Make sure not to free the namespace twice on error. */
- if (!error)
- s->ns = gfc_current_ns;
-}
-
-
-/* Add a procedure name to the global symbol table. */
-
-static void
-add_global_procedure (bool sub)
-{
- gfc_gsymbol *s;
-
- /* Only in Fortran 2003: For procedures with a binding label also the Fortran
- name is a global identifier. */
- if (!gfc_new_block->binding_label || gfc_notification_std (GFC_STD_F2008))
- {
- s = gfc_get_gsymbol (gfc_new_block->name, false);
-
- if (s->defined
- || (s->type != GSYM_UNKNOWN
- && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
- {
- gfc_global_used (s, &gfc_new_block->declared_at);
- /* Silence follow-up errors. */
- gfc_new_block->binding_label = NULL;
- }
- else
- {
- s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
- s->sym_name = gfc_new_block->name;
- s->where = gfc_new_block->declared_at;
- s->defined = 1;
- s->ns = gfc_current_ns;
- }
- }
-
- /* Don't add the symbol multiple times. */
- if (gfc_new_block->binding_label
- && (!gfc_notification_std (GFC_STD_F2008)
- || strcmp (gfc_new_block->name, gfc_new_block->binding_label) != 0))
- {
- s = gfc_get_gsymbol (gfc_new_block->binding_label, true);
-
- if (s->defined
- || (s->type != GSYM_UNKNOWN
- && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
- {
- gfc_global_used (s, &gfc_new_block->declared_at);
- /* Silence follow-up errors. */
- gfc_new_block->binding_label = NULL;
- }
- else
- {
- s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
- s->sym_name = gfc_new_block->name;
- s->binding_label = gfc_new_block->binding_label;
- s->where = gfc_new_block->declared_at;
- s->defined = 1;
- s->ns = gfc_current_ns;
- }
- }
-}
-
-
-/* Add a program to the global symbol table. */
-
-static void
-add_global_program (void)
-{
- gfc_gsymbol *s;
-
- if (gfc_new_block == NULL)
- return;
- s = gfc_get_gsymbol (gfc_new_block->name, false);
-
- if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
- gfc_global_used (s, &gfc_new_block->declared_at);
- else
- {
- s->type = GSYM_PROGRAM;
- s->where = gfc_new_block->declared_at;
- s->defined = 1;
- s->ns = gfc_current_ns;
- }
-}
-
-
-/* Resolve all the program units. */
-static void
-resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
-{
- gfc_derived_types = NULL;
- gfc_current_ns = gfc_global_ns_list;
- for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
- {
- if (gfc_current_ns->proc_name
- && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
- continue; /* Already resolved. */
-
- if (gfc_current_ns->proc_name)
- gfc_current_locus = gfc_current_ns->proc_name->declared_at;
- gfc_resolve (gfc_current_ns);
- gfc_current_ns->derived_types = gfc_derived_types;
- gfc_derived_types = NULL;
- }
-}
-
-
-static void
-clean_up_modules (gfc_gsymbol *&gsym)
-{
- if (gsym == NULL)
- return;
-
- clean_up_modules (gsym->left);
- clean_up_modules (gsym->right);
-
- if (gsym->type != GSYM_MODULE)
- return;
-
- if (gsym->ns)
- {
- gfc_current_ns = gsym->ns;
- gfc_derived_types = gfc_current_ns->derived_types;
- gfc_done_2 ();
- gsym->ns = NULL;
- }
- free (gsym);
- gsym = NULL;
-}
-
-
-/* Translate all the program units. This could be in a different order
- to resolution if there are forward references in the file. */
-static void
-translate_all_program_units (gfc_namespace *gfc_global_ns_list)
-{
- int errors;
-
- gfc_current_ns = gfc_global_ns_list;
- gfc_get_errors (NULL, &errors);
-
- /* We first translate all modules to make sure that later parts
- of the program can use the decl. Then we translate the nonmodules. */
-
- for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
- {
- if (!gfc_current_ns->proc_name
- || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
- continue;
-
- gfc_current_locus = gfc_current_ns->proc_name->declared_at;
- gfc_derived_types = gfc_current_ns->derived_types;
- gfc_generate_module_code (gfc_current_ns);
- gfc_current_ns->translated = 1;
- }
-
- gfc_current_ns = gfc_global_ns_list;
- for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
- {
- if (gfc_current_ns->proc_name
- && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
- continue;
-
- gfc_current_locus = gfc_current_ns->proc_name->declared_at;
- gfc_derived_types = gfc_current_ns->derived_types;
- gfc_generate_code (gfc_current_ns);
- gfc_current_ns->translated = 1;
- }
-
- /* Clean up all the namespaces after translation. */
- gfc_current_ns = gfc_global_ns_list;
- for (;gfc_current_ns;)
- {
- gfc_namespace *ns;
-
- if (gfc_current_ns->proc_name
- && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
- {
- gfc_current_ns = gfc_current_ns->sibling;
- continue;
- }
-
- ns = gfc_current_ns->sibling;
- gfc_derived_types = gfc_current_ns->derived_types;
- gfc_done_2 ();
- gfc_current_ns = ns;
- }
-
- clean_up_modules (gfc_gsym_root);
-}
-
-
-/* Top level parser. */
-
-bool
-gfc_parse_file (void)
-{
- int seen_program, errors_before, errors;
- gfc_state_data top, s;
- gfc_statement st;
- locus prog_locus;
- gfc_namespace *next;
-
- gfc_start_source_files ();
-
- top.state = COMP_NONE;
- top.sym = NULL;
- top.previous = NULL;
- top.head = top.tail = NULL;
- top.do_variable = NULL;
-
- gfc_state_stack = &top;
-
- gfc_clear_new_st ();
-
- gfc_statement_label = NULL;
-
- if (setjmp (eof_buf))
- return false; /* Come here on unexpected EOF */
-
- /* Prepare the global namespace that will contain the
- program units. */
- gfc_global_ns_list = next = NULL;
-
- seen_program = 0;
- errors_before = 0;
-
- /* Exit early for empty files. */
- if (gfc_at_eof ())
- goto done;
-
- in_specification_block = true;
-loop:
- gfc_init_2 ();
- st = next_statement ();
- switch (st)
- {
- case ST_NONE:
- gfc_done_2 ();
- goto done;
-
- case ST_PROGRAM:
- if (seen_program)
- goto duplicate_main;
- seen_program = 1;
- prog_locus = gfc_current_locus;
-
- push_state (&s, COMP_PROGRAM, gfc_new_block);
- main_program_symbol (gfc_current_ns, gfc_new_block->name);
- accept_statement (st);
- add_global_program ();
- parse_progunit (ST_NONE);
- goto prog_units;
-
- case ST_SUBROUTINE:
- add_global_procedure (true);
- push_state (&s, COMP_SUBROUTINE, gfc_new_block);
- accept_statement (st);
- parse_progunit (ST_NONE);
- goto prog_units;
-
- case ST_FUNCTION:
- add_global_procedure (false);
- push_state (&s, COMP_FUNCTION, gfc_new_block);
- accept_statement (st);
- parse_progunit (ST_NONE);
- goto prog_units;
-
- case ST_BLOCK_DATA:
- push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
- accept_statement (st);
- parse_block_data ();
- break;
-
- case ST_MODULE:
- push_state (&s, COMP_MODULE, gfc_new_block);
- accept_statement (st);
-
- gfc_get_errors (NULL, &errors_before);
- parse_module ();
- break;
-
- case ST_SUBMODULE:
- push_state (&s, COMP_SUBMODULE, gfc_new_block);
- accept_statement (st);
-
- gfc_get_errors (NULL, &errors_before);
- parse_module ();
- break;
-
- /* Anything else starts a nameless main program block. */
- default:
- if (seen_program)
- goto duplicate_main;
- seen_program = 1;
- prog_locus = gfc_current_locus;
-
- push_state (&s, COMP_PROGRAM, gfc_new_block);
- main_program_symbol (gfc_current_ns, "MAIN__");
- parse_progunit (st);
- goto prog_units;
- }
-
- /* Handle the non-program units. */
- gfc_current_ns->code = s.head;
-
- gfc_resolve (gfc_current_ns);
-
- /* Fix the implicit_pure attribute for those procedures who should
- not have it. */
- while (gfc_fix_implicit_pure (gfc_current_ns))
- ;
-
- /* Dump the parse tree if requested. */
- if (flag_dump_fortran_original)
- gfc_dump_parse_tree (gfc_current_ns, stdout);
-
- gfc_get_errors (NULL, &errors);
- if (s.state == COMP_MODULE || s.state == COMP_SUBMODULE)
- {
- gfc_dump_module (s.sym->name, errors_before == errors);
- gfc_current_ns->derived_types = gfc_derived_types;
- gfc_derived_types = NULL;
- goto prog_units;
- }
- else
- {
- if (errors == 0)
- gfc_generate_code (gfc_current_ns);
- pop_state ();
- gfc_done_2 ();
- }
-
- goto loop;
-
-prog_units:
- /* The main program and non-contained procedures are put
- in the global namespace list, so that they can be processed
- later and all their interfaces resolved. */
- gfc_current_ns->code = s.head;
- if (next)
- {
- for (; next->sibling; next = next->sibling)
- ;
- next->sibling = gfc_current_ns;
- }
- else
- gfc_global_ns_list = gfc_current_ns;
-
- next = gfc_current_ns;
-
- pop_state ();
- goto loop;
-
-done:
- /* Do the resolution. */
- resolve_all_program_units (gfc_global_ns_list);
-
- /* Go through all top-level namespaces and unset the implicit_pure
- attribute for any procedures that call something not pure or
- implicit_pure. Because the a procedure marked as not implicit_pure
- in one sweep may be called by another routine, we repeat this
- process until there are no more changes. */
- bool changed;
- do
- {
- changed = false;
- for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
- gfc_current_ns = gfc_current_ns->sibling)
- {
- if (gfc_fix_implicit_pure (gfc_current_ns))
- changed = true;
- }
- }
- while (changed);
-
- /* Fixup for external procedures and resolve 'omp requires'. */
- int omp_requires;
- omp_requires = 0;
- for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
- gfc_current_ns = gfc_current_ns->sibling)
- {
- omp_requires |= gfc_current_ns->omp_requires;
- gfc_check_externals (gfc_current_ns);
- }
- for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
- gfc_current_ns = gfc_current_ns->sibling)
- gfc_check_omp_requires (gfc_current_ns, omp_requires);
-
- /* Populate omp_requires_mask (needed for resolving OpenMP
- metadirectives and declare variant). */
- switch (omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
- {
- case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
- omp_requires_mask
- = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_SEQ_CST);
- break;
- case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
- omp_requires_mask
- = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_ACQ_REL);
- break;
- case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
- omp_requires_mask
- = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_RELAXED);
- break;
- }
-
- /* Do the parse tree dump. */
- gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL;
-
- for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
- if (!gfc_current_ns->proc_name
- || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
- {
- gfc_dump_parse_tree (gfc_current_ns, stdout);
- fputs ("------------------------------------------\n\n", stdout);
- }
-
- /* Dump C prototypes. */
- if (flag_c_prototypes || flag_c_prototypes_external)
- {
- fprintf (stdout,
- "#include <stddef.h>\n"
- "#ifdef __cplusplus\n"
- "#include <complex>\n"
- "#define __GFORTRAN_FLOAT_COMPLEX std::complex<float>\n"
- "#define __GFORTRAN_DOUBLE_COMPLEX std::complex<double>\n"
- "#define __GFORTRAN_LONG_DOUBLE_COMPLEX std::complex<long double>\n"
- "extern \"C\" {\n"
- "#else\n"
- "#define __GFORTRAN_FLOAT_COMPLEX float _Complex\n"
- "#define __GFORTRAN_DOUBLE_COMPLEX double _Complex\n"
- "#define __GFORTRAN_LONG_DOUBLE_COMPLEX long double _Complex\n"
- "#endif\n\n");
- }
-
- /* First dump BIND(C) prototypes. */
- if (flag_c_prototypes)
- {
- for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
- gfc_current_ns = gfc_current_ns->sibling)
- gfc_dump_c_prototypes (gfc_current_ns, stdout);
- }
-
- /* Dump external prototypes. */
- if (flag_c_prototypes_external)
- gfc_dump_external_c_prototypes (stdout);
-
- if (flag_c_prototypes || flag_c_prototypes_external)
- fprintf (stdout, "\n#ifdef __cplusplus\n}\n#endif\n");
-
- /* Do the translation. */
- translate_all_program_units (gfc_global_ns_list);
-
- /* Dump the global symbol ist. We only do this here because part
- of it is generated after mangling the identifiers in
- trans-decl.c. */
-
- if (flag_dump_fortran_global)
- gfc_dump_global_symbols (stdout);
-
- gfc_end_source_files ();
- return true;
-
-duplicate_main:
- /* If we see a duplicate main program, shut down. If the second
- instance is an implied main program, i.e. data decls or executable
- statements, we're in for lots of errors. */
- gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
- reject_statement ();
- gfc_done_2 ();
- return true;
-}
-
-/* Return true if this state data represents an OpenACC region. */
-bool
-is_oacc (gfc_state_data *sd)
-{
- switch (sd->construct->op)
- {
- case EXEC_OACC_PARALLEL_LOOP:
- case EXEC_OACC_PARALLEL:
- case EXEC_OACC_KERNELS_LOOP:
- case EXEC_OACC_KERNELS:
- case EXEC_OACC_SERIAL_LOOP:
- case EXEC_OACC_SERIAL:
- case EXEC_OACC_DATA:
- case EXEC_OACC_HOST_DATA:
- case EXEC_OACC_LOOP:
- case EXEC_OACC_UPDATE:
- case EXEC_OACC_WAIT:
- case EXEC_OACC_CACHE:
- case EXEC_OACC_ENTER_DATA:
- case EXEC_OACC_EXIT_DATA:
- case EXEC_OACC_ATOMIC:
- case EXEC_OACC_ROUTINE:
- return true;
-
- default:
- return false;
- }
-}
generated by cgit v1.1 at 2025-04-22 14:24:21 +0000