aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/match.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/match.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/match.c')
-rw-r--r--gcc/fortran/match.c7264
1 files changed, 0 insertions, 7264 deletions
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
deleted file mode 100644
index 1afc555..0000000
--- a/gcc/fortran/match.c
+++ /dev/null
@@ -1,7264 +0,0 @@
-/* Matching subroutines in all sizes, shapes and colors.
- 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 "match.h"
-#include "parse.h"
-
-int gfc_matching_ptr_assignment = 0;
-int gfc_matching_procptr_assignment = 0;
-bool gfc_matching_prefix = false;
-
-/* Stack of SELECT TYPE statements. */
-gfc_select_type_stack *select_type_stack = NULL;
-
-/* List of type parameter expressions. */
-gfc_actual_arglist *type_param_spec_list;
-
-/* For debugging and diagnostic purposes. Return the textual representation
- of the intrinsic operator OP. */
-const char *
-gfc_op2string (gfc_intrinsic_op op)
-{
- switch (op)
- {
- case INTRINSIC_UPLUS:
- case INTRINSIC_PLUS:
- return "+";
-
- case INTRINSIC_UMINUS:
- case INTRINSIC_MINUS:
- return "-";
-
- case INTRINSIC_POWER:
- return "**";
- case INTRINSIC_CONCAT:
- return "//";
- case INTRINSIC_TIMES:
- return "*";
- case INTRINSIC_DIVIDE:
- return "/";
-
- case INTRINSIC_AND:
- return ".and.";
- case INTRINSIC_OR:
- return ".or.";
- case INTRINSIC_EQV:
- return ".eqv.";
- case INTRINSIC_NEQV:
- return ".neqv.";
-
- case INTRINSIC_EQ_OS:
- return ".eq.";
- case INTRINSIC_EQ:
- return "==";
- case INTRINSIC_NE_OS:
- return ".ne.";
- case INTRINSIC_NE:
- return "/=";
- case INTRINSIC_GE_OS:
- return ".ge.";
- case INTRINSIC_GE:
- return ">=";
- case INTRINSIC_LE_OS:
- return ".le.";
- case INTRINSIC_LE:
- return "<=";
- case INTRINSIC_LT_OS:
- return ".lt.";
- case INTRINSIC_LT:
- return "<";
- case INTRINSIC_GT_OS:
- return ".gt.";
- case INTRINSIC_GT:
- return ">";
- case INTRINSIC_NOT:
- return ".not.";
-
- case INTRINSIC_ASSIGN:
- return "=";
-
- case INTRINSIC_PARENTHESES:
- return "parens";
-
- case INTRINSIC_NONE:
- return "none";
-
- /* DTIO */
- case INTRINSIC_FORMATTED:
- return "formatted";
- case INTRINSIC_UNFORMATTED:
- return "unformatted";
-
- default:
- break;
- }
-
- gfc_internal_error ("gfc_op2string(): Bad code");
- /* Not reached. */
-}
-
-
-/******************** Generic matching subroutines ************************/
-
-/* Matches a member separator. With standard FORTRAN this is '%', but with
- DEC structures we must carefully match dot ('.').
- Because operators are spelled ".op.", a dotted string such as "x.y.z..."
- can be either a component reference chain or a combination of binary
- operations.
- There is no real way to win because the string may be grammatically
- ambiguous. The following rules help avoid ambiguities - they match
- some behavior of other (older) compilers. If the rules here are changed
- the test cases should be updated. If the user has problems with these rules
- they probably deserve the consequences. Consider "x.y.z":
- (1) If any user defined operator ".y." exists, this is always y(x,z)
- (even if ".y." is the wrong type and/or x has a member y).
- (2) Otherwise if x has a member y, and y is itself a derived type,
- this is (x->y)->z, even if an intrinsic operator exists which
- can handle (x,z).
- (3) If x has no member y or (x->y) is not a derived type but ".y."
- is an intrinsic operator (such as ".eq."), this is y(x,z).
- (4) Lastly if there is no operator ".y." and x has no member "y", it is an
- error.
- It is worth noting that the logic here does not support mixed use of member
- accessors within a single string. That is, even if x has component y and y
- has component z, the following are all syntax errors:
- "x%y.z" "x.y%z" "(x.y).z" "(x%y)%z"
- */
-
-match
-gfc_match_member_sep(gfc_symbol *sym)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- locus dot_loc, start_loc;
- gfc_intrinsic_op iop;
- match m;
- gfc_symbol *tsym;
- gfc_component *c = NULL;
-
- /* What a relief: '%' is an unambiguous member separator. */
- if (gfc_match_char ('%') == MATCH_YES)
- return MATCH_YES;
-
- /* Beware ye who enter here. */
- if (!flag_dec_structure || !sym)
- return MATCH_NO;
-
- tsym = NULL;
-
- /* We may be given either a derived type variable or the derived type
- declaration itself (which actually contains the components);
- we need the latter to search for components. */
- if (gfc_fl_struct (sym->attr.flavor))
- tsym = sym;
- else if (gfc_bt_struct (sym->ts.type))
- tsym = sym->ts.u.derived;
-
- iop = INTRINSIC_NONE;
- name[0] = '\0';
- m = MATCH_NO;
-
- /* If we have to reject come back here later. */
- start_loc = gfc_current_locus;
-
- /* Look for a component access next. */
- if (gfc_match_char ('.') != MATCH_YES)
- return MATCH_NO;
-
- /* If we accept, come back here. */
- dot_loc = gfc_current_locus;
-
- /* Try to match a symbol name following the dot. */
- if (gfc_match_name (name) != MATCH_YES)
- {
- gfc_error ("Expected structure component or operator name "
- "after '.' at %C");
- goto error;
- }
-
- /* If no dot follows we have "x.y" which should be a component access. */
- if (gfc_match_char ('.') != MATCH_YES)
- goto yes;
-
- /* Now we have a string "x.y.z" which could be a nested member access
- (x->y)->z or a binary operation y on x and z. */
-
- /* First use any user-defined operators ".y." */
- if (gfc_find_uop (name, sym->ns) != NULL)
- goto no;
-
- /* Match accesses to existing derived-type components for
- derived-type vars: "x.y.z" = (x->y)->z */
- c = gfc_find_component(tsym, name, false, true, NULL);
- if (c && (gfc_bt_struct (c->ts.type) || c->ts.type == BT_CLASS))
- goto yes;
-
- /* If y is not a component or has no members, try intrinsic operators. */
- gfc_current_locus = start_loc;
- if (gfc_match_intrinsic_op (&iop) != MATCH_YES)
- {
- /* If ".y." is not an intrinsic operator but y was a valid non-
- structure component, match and leave the trailing dot to be
- dealt with later. */
- if (c)
- goto yes;
-
- gfc_error ("%qs is neither a defined operator nor a "
- "structure component in dotted string at %C", name);
- goto error;
- }
-
- /* .y. is an intrinsic operator, overriding any possible member access. */
- goto no;
-
- /* Return keeping the current locus consistent with the match result. */
-error:
- m = MATCH_ERROR;
-no:
- gfc_current_locus = start_loc;
- return m;
-yes:
- gfc_current_locus = dot_loc;
- return MATCH_YES;
-}
-
-
-/* This function scans the current statement counting the opened and closed
- parenthesis to make sure they are balanced. */
-
-match
-gfc_match_parens (void)
-{
- locus old_loc, where;
- int count;
- gfc_instring instring;
- gfc_char_t c, quote;
-
- old_loc = gfc_current_locus;
- count = 0;
- instring = NONSTRING;
- quote = ' ';
-
- for (;;)
- {
- if (count > 0)
- where = gfc_current_locus;
- c = gfc_next_char_literal (instring);
- if (c == '\n')
- break;
- if (quote == ' ' && ((c == '\'') || (c == '"')))
- {
- quote = c;
- instring = INSTRING_WARN;
- continue;
- }
- if (quote != ' ' && c == quote)
- {
- quote = ' ';
- instring = NONSTRING;
- continue;
- }
-
- if (c == '(' && quote == ' ')
- {
- count++;
- }
- if (c == ')' && quote == ' ')
- {
- count--;
- where = gfc_current_locus;
- }
- }
-
- gfc_current_locus = old_loc;
-
- if (count != 0)
- {
- gfc_error ("Missing %qs in statement at or before %L",
- count > 0? ")":"(", &where);
- return MATCH_ERROR;
- }
-
- return MATCH_YES;
-}
-
-
-/* See if the next character is a special character that has
- escaped by a \ via the -fbackslash option. */
-
-match
-gfc_match_special_char (gfc_char_t *res)
-{
- int len, i;
- gfc_char_t c, n;
- match m;
-
- m = MATCH_YES;
-
- switch ((c = gfc_next_char_literal (INSTRING_WARN)))
- {
- case 'a':
- *res = '\a';
- break;
- case 'b':
- *res = '\b';
- break;
- case 't':
- *res = '\t';
- break;
- case 'f':
- *res = '\f';
- break;
- case 'n':
- *res = '\n';
- break;
- case 'r':
- *res = '\r';
- break;
- case 'v':
- *res = '\v';
- break;
- case '\\':
- *res = '\\';
- break;
- case '0':
- *res = '\0';
- break;
-
- case 'x':
- case 'u':
- case 'U':
- /* Hexadecimal form of wide characters. */
- len = (c == 'x' ? 2 : (c == 'u' ? 4 : 8));
- n = 0;
- for (i = 0; i < len; i++)
- {
- char buf[2] = { '\0', '\0' };
-
- c = gfc_next_char_literal (INSTRING_WARN);
- if (!gfc_wide_fits_in_byte (c)
- || !gfc_check_digit ((unsigned char) c, 16))
- return MATCH_NO;
-
- buf[0] = (unsigned char) c;
- n = n << 4;
- n += strtol (buf, NULL, 16);
- }
- *res = n;
- break;
-
- default:
- /* Unknown backslash codes are simply not expanded. */
- m = MATCH_NO;
- break;
- }
-
- return m;
-}
-
-
-/* In free form, match at least one space. Always matches in fixed
- form. */
-
-match
-gfc_match_space (void)
-{
- locus old_loc;
- char c;
-
- if (gfc_current_form == FORM_FIXED)
- return MATCH_YES;
-
- old_loc = gfc_current_locus;
-
- c = gfc_next_ascii_char ();
- if (!gfc_is_whitespace (c))
- {
- gfc_current_locus = old_loc;
- return MATCH_NO;
- }
-
- gfc_gobble_whitespace ();
-
- return MATCH_YES;
-}
-
-
-/* Match an end of statement. End of statement is optional
- whitespace, followed by a ';' or '\n' or comment '!'. If a
- semicolon is found, we continue to eat whitespace and semicolons. */
-
-match
-gfc_match_eos (void)
-{
- locus old_loc;
- int flag;
- char c;
-
- flag = 0;
-
- for (;;)
- {
- old_loc = gfc_current_locus;
- gfc_gobble_whitespace ();
-
- c = gfc_next_ascii_char ();
- switch (c)
- {
- case '!':
- do
- {
- c = gfc_next_ascii_char ();
- }
- while (c != '\n');
-
- /* Fall through. */
-
- case '\n':
- return MATCH_YES;
-
- case ';':
- flag = 1;
- continue;
- }
-
- break;
- }
-
- gfc_current_locus = old_loc;
- return (flag) ? MATCH_YES : MATCH_NO;
-}
-
-
-/* Match a literal integer on the input, setting the value on
- MATCH_YES. Literal ints occur in kind-parameters as well as
- old-style character length specifications. If cnt is non-NULL it
- will be set to the number of digits. */
-
-match
-gfc_match_small_literal_int (int *value, int *cnt)
-{
- locus old_loc;
- char c;
- int i, j;
-
- old_loc = gfc_current_locus;
-
- *value = -1;
- gfc_gobble_whitespace ();
- c = gfc_next_ascii_char ();
- if (cnt)
- *cnt = 0;
-
- if (!ISDIGIT (c))
- {
- gfc_current_locus = old_loc;
- return MATCH_NO;
- }
-
- i = c - '0';
- j = 1;
-
- for (;;)
- {
- old_loc = gfc_current_locus;
- c = gfc_next_ascii_char ();
-
- if (!ISDIGIT (c))
- break;
-
- i = 10 * i + c - '0';
- j++;
-
- if (i > 99999999)
- {
- gfc_error ("Integer too large at %C");
- return MATCH_ERROR;
- }
- }
-
- gfc_current_locus = old_loc;
-
- *value = i;
- if (cnt)
- *cnt = j;
- return MATCH_YES;
-}
-
-
-/* Match a small, constant integer expression, like in a kind
- statement. On MATCH_YES, 'value' is set. */
-
-match
-gfc_match_small_int (int *value)
-{
- gfc_expr *expr;
- match m;
- int i;
-
- m = gfc_match_expr (&expr);
- if (m != MATCH_YES)
- return m;
-
- if (gfc_extract_int (expr, &i, 1))
- m = MATCH_ERROR;
- gfc_free_expr (expr);
-
- *value = i;
- return m;
-}
-
-
-/* Matches a statement label. Uses gfc_match_small_literal_int() to
- do most of the work. */
-
-match
-gfc_match_st_label (gfc_st_label **label)
-{
- locus old_loc;
- match m;
- int i, cnt;
-
- old_loc = gfc_current_locus;
-
- m = gfc_match_small_literal_int (&i, &cnt);
- if (m != MATCH_YES)
- return m;
-
- if (cnt > 5)
- {
- gfc_error ("Too many digits in statement label at %C");
- goto cleanup;
- }
-
- if (i == 0)
- {
- gfc_error ("Statement label at %C is zero");
- goto cleanup;
- }
-
- *label = gfc_get_st_label (i);
- return MATCH_YES;
-
-cleanup:
-
- gfc_current_locus = old_loc;
- return MATCH_ERROR;
-}
-
-
-/* Match and validate a label associated with a named IF, DO or SELECT
- statement. If the symbol does not have the label attribute, we add
- it. We also make sure the symbol does not refer to another
- (active) block. A matched label is pointed to by gfc_new_block. */
-
-static match
-gfc_match_label (void)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- match m;
-
- gfc_new_block = NULL;
-
- m = gfc_match (" %n :", name);
- if (m != MATCH_YES)
- return m;
-
- if (gfc_get_symbol (name, NULL, &gfc_new_block))
- {
- gfc_error ("Label name %qs at %C is ambiguous", name);
- return MATCH_ERROR;
- }
-
- if (gfc_new_block->attr.flavor == FL_LABEL)
- {
- gfc_error ("Duplicate construct label %qs at %C", name);
- return MATCH_ERROR;
- }
-
- if (!gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
- gfc_new_block->name, NULL))
- return MATCH_ERROR;
-
- return MATCH_YES;
-}
-
-
-/* See if the current input looks like a name of some sort. Modifies
- the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
- Note that options.c restricts max_identifier_length to not more
- than GFC_MAX_SYMBOL_LEN. */
-
-match
-gfc_match_name (char *buffer)
-{
- locus old_loc;
- int i;
- char c;
-
- old_loc = gfc_current_locus;
- gfc_gobble_whitespace ();
-
- c = gfc_next_ascii_char ();
- if (!(ISALPHA (c) || (c == '_' && flag_allow_leading_underscore)))
- {
- /* Special cases for unary minus and plus, which allows for a sensible
- error message for code of the form 'c = exp(-a*b) )' where an
- extra ')' appears at the end of statement. */
- if (!gfc_error_flag_test () && c != '(' && c != '-' && c != '+')
- gfc_error ("Invalid character in name at %C");
- gfc_current_locus = old_loc;
- return MATCH_NO;
- }
-
- i = 0;
-
- do
- {
- buffer[i++] = c;
-
- if (i > gfc_option.max_identifier_length)
- {
- gfc_error ("Name at %C is too long");
- return MATCH_ERROR;
- }
-
- old_loc = gfc_current_locus;
- c = gfc_next_ascii_char ();
- }
- while (ISALNUM (c) || c == '_' || (flag_dollar_ok && c == '$'));
-
- if (c == '$' && !flag_dollar_ok)
- {
- gfc_fatal_error ("Invalid character %<$%> at %L. Use %<-fdollar-ok%> to "
- "allow it as an extension", &old_loc);
- return MATCH_ERROR;
- }
-
- buffer[i] = '\0';
- gfc_current_locus = old_loc;
-
- return MATCH_YES;
-}
-
-
-/* Match a symbol on the input. Modifies the pointer to the symbol
- pointer if successful. */
-
-match
-gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc)
-{
- char buffer[GFC_MAX_SYMBOL_LEN + 1];
- match m;
-
- m = gfc_match_name (buffer);
- if (m != MATCH_YES)
- return m;
-
- if (host_assoc)
- return (gfc_get_ha_sym_tree (buffer, matched_symbol))
- ? MATCH_ERROR : MATCH_YES;
-
- if (gfc_get_sym_tree (buffer, NULL, matched_symbol, false))
- return MATCH_ERROR;
-
- return MATCH_YES;
-}
-
-
-match
-gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc)
-{
- gfc_symtree *st;
- match m;
-
- m = gfc_match_sym_tree (&st, host_assoc);
-
- if (m == MATCH_YES)
- {
- if (st)
- *matched_symbol = st->n.sym;
- else
- *matched_symbol = NULL;
- }
- else
- *matched_symbol = NULL;
- return m;
-}
-
-
-/* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
- we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
- in matchexp.c. */
-
-match
-gfc_match_intrinsic_op (gfc_intrinsic_op *result)
-{
- locus orig_loc = gfc_current_locus;
- char ch;
-
- gfc_gobble_whitespace ();
- ch = gfc_next_ascii_char ();
- switch (ch)
- {
- case '+':
- /* Matched "+". */
- *result = INTRINSIC_PLUS;
- return MATCH_YES;
-
- case '-':
- /* Matched "-". */
- *result = INTRINSIC_MINUS;
- return MATCH_YES;
-
- case '=':
- if (gfc_next_ascii_char () == '=')
- {
- /* Matched "==". */
- *result = INTRINSIC_EQ;
- return MATCH_YES;
- }
- break;
-
- case '<':
- if (gfc_peek_ascii_char () == '=')
- {
- /* Matched "<=". */
- gfc_next_ascii_char ();
- *result = INTRINSIC_LE;
- return MATCH_YES;
- }
- /* Matched "<". */
- *result = INTRINSIC_LT;
- return MATCH_YES;
-
- case '>':
- if (gfc_peek_ascii_char () == '=')
- {
- /* Matched ">=". */
- gfc_next_ascii_char ();
- *result = INTRINSIC_GE;
- return MATCH_YES;
- }
- /* Matched ">". */
- *result = INTRINSIC_GT;
- return MATCH_YES;
-
- case '*':
- if (gfc_peek_ascii_char () == '*')
- {
- /* Matched "**". */
- gfc_next_ascii_char ();
- *result = INTRINSIC_POWER;
- return MATCH_YES;
- }
- /* Matched "*". */
- *result = INTRINSIC_TIMES;
- return MATCH_YES;
-
- case '/':
- ch = gfc_peek_ascii_char ();
- if (ch == '=')
- {
- /* Matched "/=". */
- gfc_next_ascii_char ();
- *result = INTRINSIC_NE;
- return MATCH_YES;
- }
- else if (ch == '/')
- {
- /* Matched "//". */
- gfc_next_ascii_char ();
- *result = INTRINSIC_CONCAT;
- return MATCH_YES;
- }
- /* Matched "/". */
- *result = INTRINSIC_DIVIDE;
- return MATCH_YES;
-
- case '.':
- ch = gfc_next_ascii_char ();
- switch (ch)
- {
- case 'a':
- if (gfc_next_ascii_char () == 'n'
- && gfc_next_ascii_char () == 'd'
- && gfc_next_ascii_char () == '.')
- {
- /* Matched ".and.". */
- *result = INTRINSIC_AND;
- return MATCH_YES;
- }
- break;
-
- case 'e':
- if (gfc_next_ascii_char () == 'q')
- {
- ch = gfc_next_ascii_char ();
- if (ch == '.')
- {
- /* Matched ".eq.". */
- *result = INTRINSIC_EQ_OS;
- return MATCH_YES;
- }
- else if (ch == 'v')
- {
- if (gfc_next_ascii_char () == '.')
- {
- /* Matched ".eqv.". */
- *result = INTRINSIC_EQV;
- return MATCH_YES;
- }
- }
- }
- break;
-
- case 'g':
- ch = gfc_next_ascii_char ();
- if (ch == 'e')
- {
- if (gfc_next_ascii_char () == '.')
- {
- /* Matched ".ge.". */
- *result = INTRINSIC_GE_OS;
- return MATCH_YES;
- }
- }
- else if (ch == 't')
- {
- if (gfc_next_ascii_char () == '.')
- {
- /* Matched ".gt.". */
- *result = INTRINSIC_GT_OS;
- return MATCH_YES;
- }
- }
- break;
-
- case 'l':
- ch = gfc_next_ascii_char ();
- if (ch == 'e')
- {
- if (gfc_next_ascii_char () == '.')
- {
- /* Matched ".le.". */
- *result = INTRINSIC_LE_OS;
- return MATCH_YES;
- }
- }
- else if (ch == 't')
- {
- if (gfc_next_ascii_char () == '.')
- {
- /* Matched ".lt.". */
- *result = INTRINSIC_LT_OS;
- return MATCH_YES;
- }
- }
- break;
-
- case 'n':
- ch = gfc_next_ascii_char ();
- if (ch == 'e')
- {
- ch = gfc_next_ascii_char ();
- if (ch == '.')
- {
- /* Matched ".ne.". */
- *result = INTRINSIC_NE_OS;
- return MATCH_YES;
- }
- else if (ch == 'q')
- {
- if (gfc_next_ascii_char () == 'v'
- && gfc_next_ascii_char () == '.')
- {
- /* Matched ".neqv.". */
- *result = INTRINSIC_NEQV;
- return MATCH_YES;
- }
- }
- }
- else if (ch == 'o')
- {
- if (gfc_next_ascii_char () == 't'
- && gfc_next_ascii_char () == '.')
- {
- /* Matched ".not.". */
- *result = INTRINSIC_NOT;
- return MATCH_YES;
- }
- }
- break;
-
- case 'o':
- if (gfc_next_ascii_char () == 'r'
- && gfc_next_ascii_char () == '.')
- {
- /* Matched ".or.". */
- *result = INTRINSIC_OR;
- return MATCH_YES;
- }
- break;
-
- case 'x':
- if (gfc_next_ascii_char () == 'o'
- && gfc_next_ascii_char () == 'r'
- && gfc_next_ascii_char () == '.')
- {
- if (!gfc_notify_std (GFC_STD_LEGACY, ".XOR. operator at %C"))
- return MATCH_ERROR;
- /* Matched ".xor." - equivalent to ".neqv.". */
- *result = INTRINSIC_NEQV;
- return MATCH_YES;
- }
- break;
-
- default:
- break;
- }
- break;
-
- default:
- break;
- }
-
- gfc_current_locus = orig_loc;
- return MATCH_NO;
-}
-
-
-/* Match a loop control phrase:
-
- <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
-
- If the final integer expression is not present, a constant unity
- expression is returned. We don't return MATCH_ERROR until after
- the equals sign is seen. */
-
-match
-gfc_match_iterator (gfc_iterator *iter, int init_flag)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_expr *var, *e1, *e2, *e3;
- locus start;
- match m;
-
- e1 = e2 = e3 = NULL;
-
- /* Match the start of an iterator without affecting the symbol table. */
-
- start = gfc_current_locus;
- m = gfc_match (" %n =", name);
- gfc_current_locus = start;
-
- if (m != MATCH_YES)
- return MATCH_NO;
-
- m = gfc_match_variable (&var, 0);
- if (m != MATCH_YES)
- return MATCH_NO;
-
- if (var->symtree->n.sym->attr.dimension)
- {
- gfc_error ("Loop variable at %C cannot be an array");
- goto cleanup;
- }
-
- /* F2008, C617 & C565. */
- if (var->symtree->n.sym->attr.codimension)
- {
- gfc_error ("Loop variable at %C cannot be a coarray");
- goto cleanup;
- }
-
- if (var->ref != NULL)
- {
- gfc_error ("Loop variable at %C cannot be a sub-component");
- goto cleanup;
- }
-
- gfc_match_char ('=');
-
- var->symtree->n.sym->attr.implied_index = 1;
-
- m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- if (gfc_match_char (',') != MATCH_YES)
- goto syntax;
-
- m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- if (gfc_match_char (',') != MATCH_YES)
- {
- e3 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
- goto done;
- }
-
- m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_NO)
- {
- gfc_error ("Expected a step value in iterator at %C");
- goto cleanup;
- }
-
-done:
- iter->var = var;
- iter->start = e1;
- iter->end = e2;
- iter->step = e3;
- return MATCH_YES;
-
-syntax:
- gfc_error ("Syntax error in iterator at %C");
-
-cleanup:
- gfc_free_expr (e1);
- gfc_free_expr (e2);
- gfc_free_expr (e3);
-
- return MATCH_ERROR;
-}
-
-
-/* Tries to match the next non-whitespace character on the input.
- This subroutine does not return MATCH_ERROR. */
-
-match
-gfc_match_char (char c)
-{
- locus where;
-
- where = gfc_current_locus;
- gfc_gobble_whitespace ();
-
- if (gfc_next_ascii_char () == c)
- return MATCH_YES;
-
- gfc_current_locus = where;
- return MATCH_NO;
-}
-
-
-/* General purpose matching subroutine. The target string is a
- scanf-like format string in which spaces correspond to arbitrary
- whitespace (including no whitespace), characters correspond to
- themselves. The %-codes are:
-
- %% Literal percent sign
- %e Expression, pointer to a pointer is set
- %s Symbol, pointer to the symbol is set
- %n Name, character buffer is set to name
- %t Matches end of statement.
- %o Matches an intrinsic operator, returned as an INTRINSIC enum.
- %l Matches a statement label
- %v Matches a variable expression (an lvalue, except function references
- having a data pointer result)
- % Matches a required space (in free form) and optional spaces. */
-
-match
-gfc_match (const char *target, ...)
-{
- gfc_st_label **label;
- int matches, *ip;
- locus old_loc;
- va_list argp;
- char c, *np;
- match m, n;
- void **vp;
- const char *p;
-
- old_loc = gfc_current_locus;
- va_start (argp, target);
- m = MATCH_NO;
- matches = 0;
- p = target;
-
-loop:
- c = *p++;
- switch (c)
- {
- case ' ':
- gfc_gobble_whitespace ();
- goto loop;
- case '\0':
- m = MATCH_YES;
- break;
-
- case '%':
- c = *p++;
- switch (c)
- {
- case 'e':
- vp = va_arg (argp, void **);
- n = gfc_match_expr ((gfc_expr **) vp);
- if (n != MATCH_YES)
- {
- m = n;
- goto not_yes;
- }
-
- matches++;
- goto loop;
-
- case 'v':
- vp = va_arg (argp, void **);
- n = gfc_match_variable ((gfc_expr **) vp, 0);
- if (n != MATCH_YES)
- {
- m = n;
- goto not_yes;
- }
-
- matches++;
- goto loop;
-
- case 's':
- vp = va_arg (argp, void **);
- n = gfc_match_symbol ((gfc_symbol **) vp, 0);
- if (n != MATCH_YES)
- {
- m = n;
- goto not_yes;
- }
-
- matches++;
- goto loop;
-
- case 'n':
- np = va_arg (argp, char *);
- n = gfc_match_name (np);
- if (n != MATCH_YES)
- {
- m = n;
- goto not_yes;
- }
-
- matches++;
- goto loop;
-
- case 'l':
- label = va_arg (argp, gfc_st_label **);
- n = gfc_match_st_label (label);
- if (n != MATCH_YES)
- {
- m = n;
- goto not_yes;
- }
-
- matches++;
- goto loop;
-
- case 'o':
- ip = va_arg (argp, int *);
- n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip);
- if (n != MATCH_YES)
- {
- m = n;
- goto not_yes;
- }
-
- matches++;
- goto loop;
-
- case 't':
- if (gfc_match_eos () != MATCH_YES)
- {
- m = MATCH_NO;
- goto not_yes;
- }
- goto loop;
-
- case ' ':
- if (gfc_match_space () == MATCH_YES)
- goto loop;
- m = MATCH_NO;
- goto not_yes;
-
- case '%':
- break; /* Fall through to character matcher. */
-
- default:
- gfc_internal_error ("gfc_match(): Bad match code %c", c);
- }
- /* FALLTHRU */
-
- default:
-
- /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
- expect an upper case character here! */
- gcc_assert (TOLOWER (c) == c);
-
- if (c == gfc_next_ascii_char ())
- goto loop;
- break;
- }
-
-not_yes:
- va_end (argp);
-
- if (m != MATCH_YES)
- {
- /* Clean up after a failed match. */
- gfc_current_locus = old_loc;
- va_start (argp, target);
-
- p = target;
- for (; matches > 0; matches--)
- {
- while (*p++ != '%');
-
- switch (*p++)
- {
- case '%':
- matches++;
- break; /* Skip. */
-
- /* Matches that don't have to be undone */
- case 'o':
- case 'l':
- case 'n':
- case 's':
- (void) va_arg (argp, void **);
- break;
-
- case 'e':
- case 'v':
- vp = va_arg (argp, void **);
- gfc_free_expr ((struct gfc_expr *)*vp);
- *vp = NULL;
- break;
- }
- }
-
- va_end (argp);
- }
-
- return m;
-}
-
-
-/*********************** Statement level matching **********************/
-
-/* Matches the start of a program unit, which is the program keyword
- followed by an obligatory symbol. */
-
-match
-gfc_match_program (void)
-{
- gfc_symbol *sym;
- match m;
-
- m = gfc_match ("% %s%t", &sym);
-
- if (m == MATCH_NO)
- {
- gfc_error ("Invalid form of PROGRAM statement at %C");
- m = MATCH_ERROR;
- }
-
- if (m == MATCH_ERROR)
- return m;
-
- if (!gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL))
- return MATCH_ERROR;
-
- gfc_new_block = sym;
-
- return MATCH_YES;
-}
-
-
-/* Match a simple assignment statement. */
-
-match
-gfc_match_assignment (void)
-{
- gfc_expr *lvalue, *rvalue;
- locus old_loc;
- match m;
-
- old_loc = gfc_current_locus;
-
- lvalue = NULL;
- m = gfc_match (" %v =", &lvalue);
- if (m != MATCH_YES)
- {
- gfc_current_locus = old_loc;
- gfc_free_expr (lvalue);
- return MATCH_NO;
- }
-
- rvalue = NULL;
- m = gfc_match (" %e%t", &rvalue);
-
- if (m == MATCH_YES
- && rvalue->ts.type == BT_BOZ
- && lvalue->ts.type == BT_CLASS)
- {
- m = MATCH_ERROR;
- gfc_error ("BOZ literal constant at %L is neither a DATA statement "
- "value nor an actual argument of INT/REAL/DBLE/CMPLX "
- "intrinsic subprogram", &rvalue->where);
- }
-
- if (lvalue->expr_type == EXPR_CONSTANT)
- {
- /* This clobbers %len and %kind. */
- m = MATCH_ERROR;
- gfc_error ("Assignment to a constant expression at %C");
- }
-
- if (m != MATCH_YES)
- {
- gfc_current_locus = old_loc;
- gfc_free_expr (lvalue);
- gfc_free_expr (rvalue);
- return m;
- }
-
- if (!lvalue->symtree)
- {
- gfc_free_expr (lvalue);
- gfc_free_expr (rvalue);
- return MATCH_ERROR;
- }
-
-
- gfc_set_sym_referenced (lvalue->symtree->n.sym);
-
- new_st.op = EXEC_ASSIGN;
- new_st.expr1 = lvalue;
- new_st.expr2 = rvalue;
-
- gfc_check_do_variable (lvalue->symtree);
-
- return MATCH_YES;
-}
-
-
-/* Match a pointer assignment statement. */
-
-match
-gfc_match_pointer_assignment (void)
-{
- gfc_expr *lvalue, *rvalue;
- locus old_loc;
- match m;
-
- old_loc = gfc_current_locus;
-
- lvalue = rvalue = NULL;
- gfc_matching_ptr_assignment = 0;
- gfc_matching_procptr_assignment = 0;
-
- m = gfc_match (" %v =>", &lvalue);
- if (m != MATCH_YES || !lvalue->symtree)
- {
- m = MATCH_NO;
- goto cleanup;
- }
-
- if (lvalue->symtree->n.sym->attr.proc_pointer
- || gfc_is_proc_ptr_comp (lvalue))
- gfc_matching_procptr_assignment = 1;
- else
- gfc_matching_ptr_assignment = 1;
-
- m = gfc_match (" %e%t", &rvalue);
- gfc_matching_ptr_assignment = 0;
- gfc_matching_procptr_assignment = 0;
- if (m != MATCH_YES)
- goto cleanup;
-
- new_st.op = EXEC_POINTER_ASSIGN;
- new_st.expr1 = lvalue;
- new_st.expr2 = rvalue;
-
- return MATCH_YES;
-
-cleanup:
- gfc_current_locus = old_loc;
- gfc_free_expr (lvalue);
- gfc_free_expr (rvalue);
- return m;
-}
-
-
-/* We try to match an easy arithmetic IF statement. This only happens
- when just after having encountered a simple IF statement. This code
- is really duplicate with parts of the gfc_match_if code, but this is
- *much* easier. */
-
-static match
-match_arithmetic_if (void)
-{
- gfc_st_label *l1, *l2, *l3;
- gfc_expr *expr;
- match m;
-
- m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
- if (m != MATCH_YES)
- return m;
-
- if (!gfc_reference_st_label (l1, ST_LABEL_TARGET)
- || !gfc_reference_st_label (l2, ST_LABEL_TARGET)
- || !gfc_reference_st_label (l3, ST_LABEL_TARGET))
- {
- gfc_free_expr (expr);
- return MATCH_ERROR;
- }
-
- if (!gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL,
- "Arithmetic IF statement at %C"))
- return MATCH_ERROR;
-
- new_st.op = EXEC_ARITHMETIC_IF;
- new_st.expr1 = expr;
- new_st.label1 = l1;
- new_st.label2 = l2;
- new_st.label3 = l3;
-
- return MATCH_YES;
-}
-
-
-/* The IF statement is a bit of a pain. First of all, there are three
- forms of it, the simple IF, the IF that starts a block and the
- arithmetic IF.
-
- There is a problem with the simple IF and that is the fact that we
- only have a single level of undo information on symbols. What this
- means is for a simple IF, we must re-match the whole IF statement
- multiple times in order to guarantee that the symbol table ends up
- in the proper state. */
-
-static match match_simple_forall (void);
-static match match_simple_where (void);
-
-match
-gfc_match_if (gfc_statement *if_type)
-{
- gfc_expr *expr;
- gfc_st_label *l1, *l2, *l3;
- locus old_loc, old_loc2;
- gfc_code *p;
- match m, n;
-
- n = gfc_match_label ();
- if (n == MATCH_ERROR)
- return n;
-
- old_loc = gfc_current_locus;
-
- m = gfc_match (" if ", &expr);
- if (m != MATCH_YES)
- return m;
-
- if (gfc_match_char ('(') != MATCH_YES)
- {
- gfc_error ("Missing %<(%> in IF-expression at %C");
- return MATCH_ERROR;
- }
-
- m = gfc_match ("%e", &expr);
- if (m != MATCH_YES)
- return m;
-
- old_loc2 = gfc_current_locus;
- gfc_current_locus = old_loc;
-
- if (gfc_match_parens () == MATCH_ERROR)
- return MATCH_ERROR;
-
- gfc_current_locus = old_loc2;
-
- if (gfc_match_char (')') != MATCH_YES)
- {
- gfc_error ("Syntax error in IF-expression at %C");
- gfc_free_expr (expr);
- return MATCH_ERROR;
- }
-
- m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
-
- if (m == MATCH_YES)
- {
- if (n == MATCH_YES)
- {
- gfc_error ("Block label not appropriate for arithmetic IF "
- "statement at %C");
- gfc_free_expr (expr);
- return MATCH_ERROR;
- }
-
- if (!gfc_reference_st_label (l1, ST_LABEL_TARGET)
- || !gfc_reference_st_label (l2, ST_LABEL_TARGET)
- || !gfc_reference_st_label (l3, ST_LABEL_TARGET))
- {
- gfc_free_expr (expr);
- return MATCH_ERROR;
- }
-
- if (!gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL,
- "Arithmetic IF statement at %C"))
- return MATCH_ERROR;
-
- new_st.op = EXEC_ARITHMETIC_IF;
- new_st.expr1 = expr;
- new_st.label1 = l1;
- new_st.label2 = l2;
- new_st.label3 = l3;
-
- *if_type = ST_ARITHMETIC_IF;
- return MATCH_YES;
- }
-
- if (gfc_match (" then%t") == MATCH_YES)
- {
- new_st.op = EXEC_IF;
- new_st.expr1 = expr;
- *if_type = ST_IF_BLOCK;
- return MATCH_YES;
- }
-
- if (n == MATCH_YES)
- {
- gfc_error ("Block label is not appropriate for IF statement at %C");
- gfc_free_expr (expr);
- return MATCH_ERROR;
- }
-
- /* At this point the only thing left is a simple IF statement. At
- this point, n has to be MATCH_NO, so we don't have to worry about
- re-matching a block label. From what we've got so far, try
- matching an assignment. */
-
- *if_type = ST_SIMPLE_IF;
-
- m = gfc_match_assignment ();
- if (m == MATCH_YES)
- goto got_match;
-
- gfc_free_expr (expr);
- gfc_undo_symbols ();
- gfc_current_locus = old_loc;
-
- /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
- assignment was found. For MATCH_NO, continue to call the various
- matchers. */
- if (m == MATCH_ERROR)
- return MATCH_ERROR;
-
- gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */
-
- m = gfc_match_pointer_assignment ();
- if (m == MATCH_YES)
- goto got_match;
-
- gfc_free_expr (expr);
- gfc_undo_symbols ();
- gfc_current_locus = old_loc;
-
- gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */
-
- /* Look at the next keyword to see which matcher to call. Matching
- the keyword doesn't affect the symbol table, so we don't have to
- restore between tries. */
-
-#define match(string, subr, statement) \
- if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; }
-
- gfc_clear_error ();
-
- match ("allocate", gfc_match_allocate, ST_ALLOCATE)
- match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
- match ("backspace", gfc_match_backspace, ST_BACKSPACE)
- 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 ("cycle", gfc_match_cycle, ST_CYCLE)
- match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
- match ("end file", gfc_match_endfile, ST_END_FILE)
- match ("end team", gfc_match_end_team, ST_END_TEAM)
- match ("error stop", gfc_match_error_stop, ST_ERROR_STOP)
- match ("event post", gfc_match_event_post, ST_EVENT_POST)
- match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT)
- match ("exit", gfc_match_exit, ST_EXIT)
- match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE)
- match ("flush", gfc_match_flush, ST_FLUSH)
- match ("forall", match_simple_forall, ST_FORALL)
- match ("form team", gfc_match_form_team, ST_FORM_TEAM)
- match ("go to", gfc_match_goto, ST_GOTO)
- match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
- match ("inquire", gfc_match_inquire, ST_INQUIRE)
- match ("lock", gfc_match_lock, ST_LOCK)
- match ("nullify", gfc_match_nullify, ST_NULLIFY)
- match ("open", gfc_match_open, ST_OPEN)
- match ("pause", gfc_match_pause, ST_NONE)
- match ("print", gfc_match_print, ST_WRITE)
- match ("read", gfc_match_read, ST_READ)
- match ("return", gfc_match_return, ST_RETURN)
- match ("rewind", gfc_match_rewind, ST_REWIND)
- match ("stop", gfc_match_stop, ST_STOP)
- match ("wait", gfc_match_wait, ST_WAIT)
- match ("sync all", gfc_match_sync_all, ST_SYNC_CALL);
- 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)
- match ("unlock", gfc_match_unlock, ST_UNLOCK)
- match ("where", match_simple_where, ST_WHERE)
- match ("write", gfc_match_write, ST_WRITE)
-
- if (flag_dec)
- match ("type", gfc_match_print, ST_WRITE)
-
- /* 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 ())
- gfc_error ("Syntax error in IF-clause after %C");
-
- gfc_free_expr (expr);
- return MATCH_ERROR;
-
-got_match:
- if (m == MATCH_NO)
- gfc_error ("Syntax error in IF-clause after %C");
- if (m != MATCH_YES)
- {
- gfc_free_expr (expr);
- return MATCH_ERROR;
- }
-
- /* At this point, we've matched the single IF and the action clause
- is in new_st. Rearrange things so that the IF statement appears
- in new_st. */
-
- p = gfc_get_code (EXEC_IF);
- p->next = XCNEW (gfc_code);
- *p->next = new_st;
- p->next->loc = gfc_current_locus;
-
- p->expr1 = expr;
-
- gfc_clear_new_st ();
-
- new_st.op = EXEC_IF;
- new_st.block = p;
-
- return MATCH_YES;
-}
-
-#undef match
-
-
-/* Match an ELSE statement. */
-
-match
-gfc_match_else (void)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
-
- if (gfc_match_eos () == MATCH_YES)
- return MATCH_YES;
-
- if (gfc_match_name (name) != MATCH_YES
- || gfc_current_block () == NULL
- || gfc_match_eos () != MATCH_YES)
- {
- gfc_error ("Invalid character(s) in ELSE statement after %C");
- return MATCH_ERROR;
- }
-
- if (strcmp (name, gfc_current_block ()->name) != 0)
- {
- gfc_error ("Label %qs at %C doesn't match IF label %qs",
- name, gfc_current_block ()->name);
- return MATCH_ERROR;
- }
-
- return MATCH_YES;
-}
-
-
-/* Match an ELSE IF statement. */
-
-match
-gfc_match_elseif (void)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_expr *expr, *then;
- locus where;
- match m;
-
- if (gfc_match_char ('(') != MATCH_YES)
- {
- gfc_error ("Missing %<(%> in ELSE IF expression at %C");
- return MATCH_ERROR;
- }
-
- m = gfc_match (" %e ", &expr);
- if (m != MATCH_YES)
- return m;
-
- if (gfc_match_char (')') != MATCH_YES)
- {
- gfc_error ("Missing %<)%> in ELSE IF expression at %C");
- goto cleanup;
- }
-
- m = gfc_match (" then ", &then);
-
- where = gfc_current_locus;
-
- if (m == MATCH_YES && (gfc_match_eos () == MATCH_YES
- || (gfc_current_block ()
- && gfc_match_name (name) == MATCH_YES)))
- goto done;
-
- if (gfc_match_eos () == MATCH_YES)
- {
- gfc_error ("Missing THEN in ELSE IF statement after %L", &where);
- goto cleanup;
- }
-
- if (gfc_match_name (name) != MATCH_YES
- || gfc_current_block () == NULL
- || gfc_match_eos () != MATCH_YES)
- {
- gfc_error ("Syntax error in ELSE IF statement after %L", &where);
- goto cleanup;
- }
-
- if (strcmp (name, gfc_current_block ()->name) != 0)
- {
- gfc_error ("Label %qs after %L doesn't match IF label %qs",
- name, &where, gfc_current_block ()->name);
- goto cleanup;
- }
-
- if (m != MATCH_YES)
- return m;
-
-done:
- new_st.op = EXEC_IF;
- new_st.expr1 = expr;
- return MATCH_YES;
-
-cleanup:
- gfc_free_expr (expr);
- return MATCH_ERROR;
-}
-
-
-/* Free a gfc_iterator structure. */
-
-void
-gfc_free_iterator (gfc_iterator *iter, int flag)
-{
-
- if (iter == NULL)
- return;
-
- gfc_free_expr (iter->var);
- gfc_free_expr (iter->start);
- gfc_free_expr (iter->end);
- gfc_free_expr (iter->step);
-
- if (flag)
- free (iter);
-}
-
-
-/* Match a CRITICAL statement. */
-match
-gfc_match_critical (void)
-{
- gfc_st_label *label = NULL;
-
- if (gfc_match_label () == MATCH_ERROR)
- return MATCH_ERROR;
-
- if (gfc_match (" critical") != MATCH_YES)
- return MATCH_NO;
-
- if (gfc_match_st_label (&label) == MATCH_ERROR)
- return MATCH_ERROR;
-
- if (gfc_match_eos () != MATCH_YES)
- {
- gfc_syntax_error (ST_CRITICAL);
- return MATCH_ERROR;
- }
-
- if (gfc_pure (NULL))
- {
- gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
- return MATCH_ERROR;
- }
-
- if (gfc_find_state (COMP_DO_CONCURRENT))
- {
- gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
- "block");
- return MATCH_ERROR;
- }
-
- gfc_unset_implicit_pure (NULL);
-
- if (!gfc_notify_std (GFC_STD_F2008, "CRITICAL statement at %C"))
- return MATCH_ERROR;
-
- if (flag_coarray == GFC_FCOARRAY_NONE)
- {
- gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
- "enable");
- return MATCH_ERROR;
- }
-
- if (gfc_find_state (COMP_CRITICAL))
- {
- gfc_error ("Nested CRITICAL block at %C");
- return MATCH_ERROR;
- }
-
- new_st.op = EXEC_CRITICAL;
-
- if (label != NULL
- && !gfc_reference_st_label (label, ST_LABEL_TARGET))
- return MATCH_ERROR;
-
- return MATCH_YES;
-}
-
-
-/* Match a BLOCK statement. */
-
-match
-gfc_match_block (void)
-{
- match m;
-
- if (gfc_match_label () == MATCH_ERROR)
- return MATCH_ERROR;
-
- if (gfc_match (" block") != MATCH_YES)
- return MATCH_NO;
-
- /* For this to be a correct BLOCK statement, the line must end now. */
- m = gfc_match_eos ();
- if (m == MATCH_ERROR)
- return MATCH_ERROR;
- if (m == MATCH_NO)
- return MATCH_NO;
-
- return MATCH_YES;
-}
-
-
-/* Match an ASSOCIATE statement. */
-
-match
-gfc_match_associate (void)
-{
- if (gfc_match_label () == MATCH_ERROR)
- return MATCH_ERROR;
-
- if (gfc_match (" associate") != MATCH_YES)
- return MATCH_NO;
-
- /* Match the association list. */
- if (gfc_match_char ('(') != MATCH_YES)
- {
- gfc_error ("Expected association list at %C");
- return MATCH_ERROR;
- }
- new_st.ext.block.assoc = NULL;
- while (true)
- {
- gfc_association_list* newAssoc = gfc_get_association_list ();
- gfc_association_list* a;
-
- /* Match the next association. */
- if (gfc_match (" %n =>", newAssoc->name) != MATCH_YES)
- {
- gfc_error ("Expected association at %C");
- goto assocListError;
- }
-
- if (gfc_match (" %e", &newAssoc->target) != MATCH_YES)
- {
- /* Have another go, allowing for procedure pointer selectors. */
- gfc_matching_procptr_assignment = 1;
- if (gfc_match (" %e", &newAssoc->target) != MATCH_YES)
- {
- gfc_error ("Invalid association target at %C");
- goto assocListError;
- }
- gfc_matching_procptr_assignment = 0;
- }
- newAssoc->where = gfc_current_locus;
-
- /* Check that the current name is not yet in the list. */
- for (a = new_st.ext.block.assoc; a; a = a->next)
- if (!strcmp (a->name, newAssoc->name))
- {
- gfc_error ("Duplicate name %qs in association at %C",
- newAssoc->name);
- goto assocListError;
- }
-
- /* The target expression must not be coindexed. */
- if (gfc_is_coindexed (newAssoc->target))
- {
- gfc_error ("Association target at %C must not be coindexed");
- goto assocListError;
- }
-
- /* The target expression cannot be a BOZ literal constant. */
- if (newAssoc->target->ts.type == BT_BOZ)
- {
- gfc_error ("Association target at %L cannot be a BOZ literal "
- "constant", &newAssoc->target->where);
- goto assocListError;
- }
-
- /* The `variable' field is left blank for now; because the target is not
- yet resolved, we can't use gfc_has_vector_subscript to determine it
- for now. This is set during resolution. */
-
- /* Put it into the list. */
- newAssoc->next = new_st.ext.block.assoc;
- new_st.ext.block.assoc = newAssoc;
-
- /* Try next one or end if closing parenthesis is found. */
- gfc_gobble_whitespace ();
- if (gfc_peek_char () == ')')
- break;
- if (gfc_match_char (',') != MATCH_YES)
- {
- gfc_error ("Expected %<)%> or %<,%> at %C");
- return MATCH_ERROR;
- }
-
- continue;
-
-assocListError:
- free (newAssoc);
- goto error;
- }
- if (gfc_match_char (')') != MATCH_YES)
- {
- /* This should never happen as we peek above. */
- gcc_unreachable ();
- }
-
- if (gfc_match_eos () != MATCH_YES)
- {
- gfc_error ("Junk after ASSOCIATE statement at %C");
- goto error;
- }
-
- return MATCH_YES;
-
-error:
- gfc_free_association_list (new_st.ext.block.assoc);
- return MATCH_ERROR;
-}
-
-
-/* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
- an accessible derived type. */
-
-static match
-match_derived_type_spec (gfc_typespec *ts)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- locus old_locus;
- gfc_symbol *derived, *der_type;
- match m = MATCH_YES;
- gfc_actual_arglist *decl_type_param_list = NULL;
- bool is_pdt_template = false;
-
- old_locus = gfc_current_locus;
-
- if (gfc_match ("%n", name) != MATCH_YES)
- {
- gfc_current_locus = old_locus;
- return MATCH_NO;
- }
-
- gfc_find_symbol (name, NULL, 1, &derived);
-
- /* Match the PDT spec list, if there. */
- if (derived && derived->attr.flavor == FL_PROCEDURE)
- {
- gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &der_type);
- is_pdt_template = der_type
- && der_type->attr.flavor == FL_DERIVED
- && der_type->attr.pdt_template;
- }
-
- if (is_pdt_template)
- m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
-
- if (m == MATCH_ERROR)
- {
- gfc_free_actual_arglist (decl_type_param_list);
- return m;
- }
-
- if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic)
- derived = gfc_find_dt_in_generic (derived);
-
- /* If this is a PDT, find the specific instance. */
- if (m == MATCH_YES && is_pdt_template)
- {
- gfc_namespace *old_ns;
-
- old_ns = gfc_current_ns;
- while (gfc_current_ns && gfc_current_ns->parent)
- gfc_current_ns = gfc_current_ns->parent;
-
- if (type_param_spec_list)
- gfc_free_actual_arglist (type_param_spec_list);
- m = gfc_get_pdt_instance (decl_type_param_list, &der_type,
- &type_param_spec_list);
- gfc_free_actual_arglist (decl_type_param_list);
-
- if (m != MATCH_YES)
- return m;
- derived = der_type;
- gcc_assert (!derived->attr.pdt_template && derived->attr.pdt_type);
- gfc_set_sym_referenced (derived);
-
- gfc_current_ns = old_ns;
- }
-
- if (derived && derived->attr.flavor == FL_DERIVED)
- {
- ts->type = BT_DERIVED;
- ts->u.derived = derived;
- return MATCH_YES;
- }
-
- gfc_current_locus = old_locus;
- return MATCH_NO;
-}
-
-
-/* Match a Fortran 2003 type-spec (F03:R401). This is similar to
- gfc_match_decl_type_spec() from decl.c, with the following exceptions:
- It only includes the intrinsic types from the Fortran 2003 standard
- (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
- the implicit_flag is not needed, so it was removed. Derived types are
- identified by their name alone. */
-
-match
-gfc_match_type_spec (gfc_typespec *ts)
-{
- match m;
- locus old_locus;
- char c, name[GFC_MAX_SYMBOL_LEN + 1];
-
- gfc_clear_ts (ts);
- gfc_gobble_whitespace ();
- old_locus = gfc_current_locus;
-
- /* If c isn't [a-z], then return immediately. */
- c = gfc_peek_ascii_char ();
- if (!ISALPHA(c))
- return MATCH_NO;
-
- type_param_spec_list = NULL;
-
- if (match_derived_type_spec (ts) == MATCH_YES)
- {
- /* Enforce F03:C401. */
- if (ts->u.derived->attr.abstract)
- {
- gfc_error ("Derived type %qs at %L may not be ABSTRACT",
- ts->u.derived->name, &old_locus);
- return MATCH_ERROR;
- }
- return MATCH_YES;
- }
-
- if (gfc_match ("integer") == MATCH_YES)
- {
- ts->type = BT_INTEGER;
- ts->kind = gfc_default_integer_kind;
- goto kind_selector;
- }
-
- if (gfc_match ("double precision") == MATCH_YES)
- {
- ts->type = BT_REAL;
- ts->kind = gfc_default_double_kind;
- return MATCH_YES;
- }
-
- if (gfc_match ("complex") == MATCH_YES)
- {
- ts->type = BT_COMPLEX;
- ts->kind = gfc_default_complex_kind;
- goto kind_selector;
- }
-
- if (gfc_match ("character") == MATCH_YES)
- {
- ts->type = BT_CHARACTER;
-
- m = gfc_match_char_spec (ts);
-
- if (m == MATCH_NO)
- m = MATCH_YES;
-
- return m;
- }
-
- /* REAL is a real pain because it can be a type, intrinsic subprogram,
- or list item in a type-list of an OpenMP reduction clause. Need to
- differentiate REAL([KIND]=scalar-int-initialization-expr) from
- REAL(A,[KIND]) and REAL(KIND,A). Logically, when this code was
- written the use of LOGICAL as a type-spec or intrinsic subprogram
- was overlooked. */
-
- m = gfc_match (" %n", name);
- if (m == MATCH_YES
- && (strcmp (name, "real") == 0 || strcmp (name, "logical") == 0))
- {
- char c;
- gfc_expr *e;
- locus where;
-
- if (*name == 'r')
- {
- ts->type = BT_REAL;
- ts->kind = gfc_default_real_kind;
- }
- else
- {
- ts->type = BT_LOGICAL;
- ts->kind = gfc_default_logical_kind;
- }
-
- gfc_gobble_whitespace ();
-
- /* Prevent REAL*4, etc. */
- c = gfc_peek_ascii_char ();
- if (c == '*')
- {
- gfc_error ("Invalid type-spec at %C");
- return MATCH_ERROR;
- }
-
- /* Found leading colon in REAL::, a trailing ')' in for example
- TYPE IS (REAL), or REAL, for an OpenMP list-item. */
- if (c == ':' || c == ')' || (flag_openmp && c == ','))
- return MATCH_YES;
-
- /* Found something other than the opening '(' in REAL(... */
- if (c != '(')
- return MATCH_NO;
- else
- gfc_next_char (); /* Burn the '('. */
-
- /* Look for the optional KIND=. */
- where = gfc_current_locus;
- m = gfc_match ("%n", name);
- if (m == MATCH_YES)
- {
- gfc_gobble_whitespace ();
- c = gfc_next_char ();
- if (c == '=')
- {
- if (strcmp(name, "a") == 0 || strcmp(name, "l") == 0)
- return MATCH_NO;
- else if (strcmp(name, "kind") == 0)
- goto found;
- else
- return MATCH_ERROR;
- }
- else
- gfc_current_locus = where;
- }
- else
- gfc_current_locus = where;
-
-found:
-
- m = gfc_match_expr (&e);
- if (m == MATCH_NO || m == MATCH_ERROR)
- return m;
-
- /* If a comma appears, it is an intrinsic subprogram. */
- gfc_gobble_whitespace ();
- c = gfc_peek_ascii_char ();
- if (c == ',')
- {
- gfc_free_expr (e);
- return MATCH_NO;
- }
-
- /* If ')' appears, we have REAL(initialization-expr), here check for
- a scalar integer initialization-expr and valid kind parameter. */
- if (c == ')')
- {
- bool ok = true;
- if (e->expr_type != EXPR_CONSTANT && e->expr_type != EXPR_VARIABLE)
- ok = gfc_reduce_init_expr (e);
- if (!ok || e->ts.type != BT_INTEGER || e->rank > 0)
- {
- gfc_free_expr (e);
- return MATCH_NO;
- }
-
- if (e->expr_type != EXPR_CONSTANT)
- goto ohno;
-
- gfc_next_char (); /* Burn the ')'. */
- ts->kind = (int) mpz_get_si (e->value.integer);
- if (gfc_validate_kind (ts->type, ts->kind , true) == -1)
- {
- gfc_error ("Invalid type-spec at %C");
- return MATCH_ERROR;
- }
-
- gfc_free_expr (e);
-
- return MATCH_YES;
- }
- }
-
-ohno:
-
- /* If a type is not matched, simply return MATCH_NO. */
- gfc_current_locus = old_locus;
- return MATCH_NO;
-
-kind_selector:
-
- gfc_gobble_whitespace ();
-
- /* This prevents INTEGER*4, etc. */
- if (gfc_peek_ascii_char () == '*')
- {
- gfc_error ("Invalid type-spec at %C");
- return MATCH_ERROR;
- }
-
- m = gfc_match_kind_spec (ts, false);
-
- /* No kind specifier found. */
- if (m == MATCH_NO)
- m = MATCH_YES;
-
- return m;
-}
-
-
-/******************** FORALL subroutines ********************/
-
-/* Free a list of FORALL iterators. */
-
-void
-gfc_free_forall_iterator (gfc_forall_iterator *iter)
-{
- gfc_forall_iterator *next;
-
- while (iter)
- {
- next = iter->next;
- gfc_free_expr (iter->var);
- gfc_free_expr (iter->start);
- gfc_free_expr (iter->end);
- gfc_free_expr (iter->stride);
- free (iter);
- iter = next;
- }
-}
-
-
-/* Match an iterator as part of a FORALL statement. The format is:
-
- <var> = <start>:<end>[:<stride>]
-
- On MATCH_NO, the caller tests for the possibility that there is a
- scalar mask expression. */
-
-static match
-match_forall_iterator (gfc_forall_iterator **result)
-{
- gfc_forall_iterator *iter;
- locus where;
- match m;
-
- where = gfc_current_locus;
- iter = XCNEW (gfc_forall_iterator);
-
- m = gfc_match_expr (&iter->var);
- if (m != MATCH_YES)
- goto cleanup;
-
- if (gfc_match_char ('=') != MATCH_YES
- || iter->var->expr_type != EXPR_VARIABLE)
- {
- m = MATCH_NO;
- goto cleanup;
- }
-
- m = gfc_match_expr (&iter->start);
- if (m != MATCH_YES)
- goto cleanup;
-
- if (gfc_match_char (':') != MATCH_YES)
- goto syntax;
-
- m = gfc_match_expr (&iter->end);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- if (gfc_match_char (':') == MATCH_NO)
- iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
- else
- {
- m = gfc_match_expr (&iter->stride);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
- }
-
- /* Mark the iteration variable's symbol as used as a FORALL index. */
- iter->var->symtree->n.sym->forall_index = true;
-
- *result = iter;
- return MATCH_YES;
-
-syntax:
- gfc_error ("Syntax error in FORALL iterator at %C");
- m = MATCH_ERROR;
-
-cleanup:
-
- gfc_current_locus = where;
- gfc_free_forall_iterator (iter);
- return m;
-}
-
-
-/* Match the header of a FORALL statement. */
-
-static match
-match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
-{
- gfc_forall_iterator *head, *tail, *new_iter;
- gfc_expr *msk;
- match m;
-
- gfc_gobble_whitespace ();
-
- head = tail = NULL;
- msk = NULL;
-
- if (gfc_match_char ('(') != MATCH_YES)
- return MATCH_NO;
-
- m = match_forall_iterator (&new_iter);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_NO)
- goto syntax;
-
- head = tail = new_iter;
-
- for (;;)
- {
- if (gfc_match_char (',') != MATCH_YES)
- break;
-
- m = match_forall_iterator (&new_iter);
- if (m == MATCH_ERROR)
- goto cleanup;
-
- if (m == MATCH_YES)
- {
- tail->next = new_iter;
- tail = new_iter;
- continue;
- }
-
- /* Have to have a mask expression. */
-
- m = gfc_match_expr (&msk);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- break;
- }
-
- if (gfc_match_char (')') == MATCH_NO)
- goto syntax;
-
- *phead = head;
- *mask = msk;
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_FORALL);
-
-cleanup:
- gfc_free_expr (msk);
- gfc_free_forall_iterator (head);
-
- return MATCH_ERROR;
-}
-
-/* Match the rest of a simple FORALL statement that follows an
- IF statement. */
-
-static match
-match_simple_forall (void)
-{
- gfc_forall_iterator *head;
- gfc_expr *mask;
- gfc_code *c;
- match m;
-
- mask = NULL;
- head = NULL;
- c = NULL;
-
- m = match_forall_header (&head, &mask);
-
- if (m == MATCH_NO)
- goto syntax;
- if (m != MATCH_YES)
- goto cleanup;
-
- m = gfc_match_assignment ();
-
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_NO)
- {
- m = gfc_match_pointer_assignment ();
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_NO)
- goto syntax;
- }
-
- c = XCNEW (gfc_code);
- *c = new_st;
- c->loc = gfc_current_locus;
-
- if (gfc_match_eos () != MATCH_YES)
- goto syntax;
-
- gfc_clear_new_st ();
- new_st.op = EXEC_FORALL;
- new_st.expr1 = mask;
- new_st.ext.forall_iterator = head;
- new_st.block = gfc_get_code (EXEC_FORALL);
- new_st.block->next = c;
-
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_FORALL);
-
-cleanup:
- gfc_free_forall_iterator (head);
- gfc_free_expr (mask);
-
- return MATCH_ERROR;
-}
-
-
-/* Match a FORALL statement. */
-
-match
-gfc_match_forall (gfc_statement *st)
-{
- gfc_forall_iterator *head;
- gfc_expr *mask;
- gfc_code *c;
- match m0, m;
-
- head = NULL;
- mask = NULL;
- c = NULL;
-
- m0 = gfc_match_label ();
- if (m0 == MATCH_ERROR)
- return MATCH_ERROR;
-
- m = gfc_match (" forall");
- if (m != MATCH_YES)
- return m;
-
- m = match_forall_header (&head, &mask);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_NO)
- goto syntax;
-
- if (gfc_match_eos () == MATCH_YES)
- {
- *st = ST_FORALL_BLOCK;
- new_st.op = EXEC_FORALL;
- new_st.expr1 = mask;
- new_st.ext.forall_iterator = head;
- return MATCH_YES;
- }
-
- m = gfc_match_assignment ();
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_NO)
- {
- m = gfc_match_pointer_assignment ();
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_NO)
- goto syntax;
- }
-
- c = XCNEW (gfc_code);
- *c = new_st;
- c->loc = gfc_current_locus;
-
- gfc_clear_new_st ();
- new_st.op = EXEC_FORALL;
- new_st.expr1 = mask;
- new_st.ext.forall_iterator = head;
- new_st.block = gfc_get_code (EXEC_FORALL);
- new_st.block->next = c;
-
- *st = ST_FORALL;
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_FORALL);
-
-cleanup:
- gfc_free_forall_iterator (head);
- gfc_free_expr (mask);
- gfc_free_statements (c);
- return MATCH_NO;
-}
-
-
-/* Match a DO statement. */
-
-match
-gfc_match_do (void)
-{
- gfc_iterator iter, *ip;
- locus old_loc;
- gfc_st_label *label;
- match m;
-
- old_loc = gfc_current_locus;
-
- memset (&iter, '\0', sizeof (gfc_iterator));
- label = NULL;
-
- m = gfc_match_label ();
- if (m == MATCH_ERROR)
- return m;
-
- if (gfc_match (" do") != MATCH_YES)
- return MATCH_NO;
-
- m = gfc_match_st_label (&label);
- if (m == MATCH_ERROR)
- goto cleanup;
-
- /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
-
- if (gfc_match_eos () == MATCH_YES)
- {
- iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true);
- new_st.op = EXEC_DO_WHILE;
- goto done;
- }
-
- /* Match an optional comma, if no comma is found, a space is obligatory. */
- if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
- return MATCH_NO;
-
- /* Check for balanced parens. */
-
- if (gfc_match_parens () == MATCH_ERROR)
- return MATCH_ERROR;
-
- if (gfc_match (" concurrent") == MATCH_YES)
- {
- gfc_forall_iterator *head;
- gfc_expr *mask;
-
- if (!gfc_notify_std (GFC_STD_F2008, "DO CONCURRENT construct at %C"))
- return MATCH_ERROR;
-
-
- mask = NULL;
- head = NULL;
- m = match_forall_header (&head, &mask);
-
- if (m == MATCH_NO)
- return m;
- if (m == MATCH_ERROR)
- goto concurr_cleanup;
-
- if (gfc_match_eos () != MATCH_YES)
- goto concurr_cleanup;
-
- if (label != NULL
- && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET))
- goto concurr_cleanup;
-
- new_st.label1 = label;
- new_st.op = EXEC_DO_CONCURRENT;
- new_st.expr1 = mask;
- new_st.ext.forall_iterator = head;
-
- return MATCH_YES;
-
-concurr_cleanup:
- gfc_syntax_error (ST_DO);
- gfc_free_expr (mask);
- gfc_free_forall_iterator (head);
- return MATCH_ERROR;
- }
-
- /* See if we have a DO WHILE. */
- if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
- {
- new_st.op = EXEC_DO_WHILE;
- goto done;
- }
-
- /* The abortive DO WHILE may have done something to the symbol
- table, so we start over. */
- gfc_undo_symbols ();
- gfc_current_locus = old_loc;
-
- gfc_match_label (); /* This won't error. */
- gfc_match (" do "); /* This will work. */
-
- gfc_match_st_label (&label); /* Can't error out. */
- gfc_match_char (','); /* Optional comma. */
-
- m = gfc_match_iterator (&iter, 0);
- if (m == MATCH_NO)
- return MATCH_NO;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- iter.var->symtree->n.sym->attr.implied_index = 0;
- gfc_check_do_variable (iter.var->symtree);
-
- if (gfc_match_eos () != MATCH_YES)
- {
- gfc_syntax_error (ST_DO);
- goto cleanup;
- }
-
- new_st.op = EXEC_DO;
-
-done:
- if (label != NULL
- && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET))
- goto cleanup;
-
- new_st.label1 = label;
-
- if (new_st.op == EXEC_DO_WHILE)
- new_st.expr1 = iter.end;
- else
- {
- new_st.ext.iterator = ip = gfc_get_iterator ();
- *ip = iter;
- }
-
- return MATCH_YES;
-
-cleanup:
- gfc_free_iterator (&iter, 0);
-
- return MATCH_ERROR;
-}
-
-
-/* Match an EXIT or CYCLE statement. */
-
-static match
-match_exit_cycle (gfc_statement st, gfc_exec_op op)
-{
- gfc_state_data *p, *o;
- gfc_symbol *sym;
- match m;
- int cnt;
-
- if (gfc_match_eos () == MATCH_YES)
- sym = NULL;
- else
- {
- char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_symtree* stree;
-
- m = gfc_match ("% %n%t", name);
- if (m == MATCH_ERROR)
- return MATCH_ERROR;
- if (m == MATCH_NO)
- {
- gfc_syntax_error (st);
- return MATCH_ERROR;
- }
-
- /* Find the corresponding symbol. If there's a BLOCK statement
- between here and the label, it is not in gfc_current_ns but a parent
- namespace! */
- stree = gfc_find_symtree_in_proc (name, gfc_current_ns);
- if (!stree)
- {
- gfc_error ("Name %qs in %s statement at %C is unknown",
- name, gfc_ascii_statement (st));
- return MATCH_ERROR;
- }
-
- sym = stree->n.sym;
- if (sym->attr.flavor != FL_LABEL)
- {
- gfc_error ("Name %qs in %s statement at %C is not a construct name",
- name, gfc_ascii_statement (st));
- return MATCH_ERROR;
- }
- }
-
- /* Find the loop specified by the label (or lack of a label). */
- for (o = NULL, p = gfc_state_stack; p; p = p->previous)
- if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
- o = p;
- else if (p->state == COMP_CRITICAL)
- {
- gfc_error("%s statement at %C leaves CRITICAL construct",
- gfc_ascii_statement (st));
- return MATCH_ERROR;
- }
- else if (p->state == COMP_DO_CONCURRENT
- && (op == EXEC_EXIT || (sym && sym != p->sym)))
- {
- /* F2008, C821 & C845. */
- gfc_error("%s statement at %C leaves DO CONCURRENT construct",
- gfc_ascii_statement (st));
- return MATCH_ERROR;
- }
- else if ((sym && sym == p->sym)
- || (!sym && (p->state == COMP_DO
- || p->state == COMP_DO_CONCURRENT)))
- break;
-
- if (p == NULL)
- {
- if (sym == NULL)
- gfc_error ("%s statement at %C is not within a construct",
- gfc_ascii_statement (st));
- else
- gfc_error ("%s statement at %C is not within construct %qs",
- gfc_ascii_statement (st), sym->name);
-
- return MATCH_ERROR;
- }
-
- /* Special checks for EXIT from non-loop constructs. */
- switch (p->state)
- {
- case COMP_DO:
- case COMP_DO_CONCURRENT:
- break;
-
- case COMP_CRITICAL:
- /* This is already handled above. */
- gcc_unreachable ();
-
- case COMP_ASSOCIATE:
- case COMP_BLOCK:
- case COMP_IF:
- case COMP_SELECT:
- case COMP_SELECT_TYPE:
- case COMP_SELECT_RANK:
- gcc_assert (sym);
- if (op == EXEC_CYCLE)
- {
- gfc_error ("CYCLE statement at %C is not applicable to non-loop"
- " construct %qs", sym->name);
- return MATCH_ERROR;
- }
- gcc_assert (op == EXEC_EXIT);
- if (!gfc_notify_std (GFC_STD_F2008, "EXIT statement with no"
- " do-construct-name at %C"))
- return MATCH_ERROR;
- break;
-
- default:
- gfc_error ("%s statement at %C is not applicable to construct %qs",
- gfc_ascii_statement (st), sym->name);
- return MATCH_ERROR;
- }
-
- if (o != NULL)
- {
- gfc_error (is_oacc (p)
- ? G_("%s statement at %C leaving OpenACC structured block")
- : G_("%s statement at %C leaving OpenMP structured block"),
- gfc_ascii_statement (st));
- return MATCH_ERROR;
- }
-
- for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++)
- o = o->previous;
- if (cnt > 0
- && o != NULL
- && o->state == COMP_OMP_STRUCTURED_BLOCK
- && (o->head->op == EXEC_OACC_LOOP
- || o->head->op == EXEC_OACC_KERNELS_LOOP
- || o->head->op == EXEC_OACC_PARALLEL_LOOP
- || o->head->op == EXEC_OACC_SERIAL_LOOP))
- {
- int collapse = 1;
- gcc_assert (o->head->next != NULL
- && (o->head->next->op == EXEC_DO
- || o->head->next->op == EXEC_DO_WHILE)
- && o->previous != NULL
- && o->previous->tail->op == o->head->op);
- if (o->previous->tail->ext.omp_clauses != NULL)
- {
- /* Both collapsed and tiled loops are lowered the same way, but are not
- compatible. In gfc_trans_omp_do, the tile is prioritized. */
- if (o->previous->tail->ext.omp_clauses->tile_list)
- {
- collapse = 0;
- gfc_expr_list *el = o->previous->tail->ext.omp_clauses->tile_list;
- for ( ; el; el = el->next)
- ++collapse;
- }
- else if (o->previous->tail->ext.omp_clauses->collapse > 1)
- collapse = o->previous->tail->ext.omp_clauses->collapse;
- }
- if (st == ST_EXIT && cnt <= collapse)
- {
- gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
- return MATCH_ERROR;
- }
- if (st == ST_CYCLE && cnt < collapse)
- {
- gfc_error (o->previous->tail->ext.omp_clauses->tile_list
- ? G_("CYCLE statement at %C to non-innermost tiled"
- " !$ACC LOOP loop")
- : G_("CYCLE statement at %C to non-innermost collapsed"
- " !$ACC LOOP loop"));
- return MATCH_ERROR;
- }
- }
- if (cnt > 0
- && o != NULL
- && (o->state == COMP_OMP_STRUCTURED_BLOCK)
- && (o->head->op == EXEC_OMP_DO
- || o->head->op == EXEC_OMP_PARALLEL_DO
- || o->head->op == EXEC_OMP_SIMD
- || o->head->op == EXEC_OMP_DO_SIMD
- || o->head->op == EXEC_OMP_PARALLEL_DO_SIMD))
- {
- int count = 1;
- gcc_assert (o->head->next != NULL
- && (o->head->next->op == EXEC_DO
- || o->head->next->op == EXEC_DO_WHILE)
- && o->previous != NULL
- && o->previous->tail->op == o->head->op);
- if (o->previous->tail->ext.omp_clauses != NULL)
- {
- if (o->previous->tail->ext.omp_clauses->collapse > 1)
- count = o->previous->tail->ext.omp_clauses->collapse;
- if (o->previous->tail->ext.omp_clauses->orderedc)
- count = o->previous->tail->ext.omp_clauses->orderedc;
- }
- if (st == ST_EXIT && cnt <= count)
- {
- gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
- return MATCH_ERROR;
- }
- if (st == ST_CYCLE && cnt < count)
- {
- gfc_error ("CYCLE statement at %C to non-innermost collapsed"
- " !$OMP DO loop");
- return MATCH_ERROR;
- }
- }
-
- /* Save the first statement in the construct - needed by the backend. */
- new_st.ext.which_construct = p->construct;
-
- new_st.op = op;
-
- return MATCH_YES;
-}
-
-
-/* Match the EXIT statement. */
-
-match
-gfc_match_exit (void)
-{
- return match_exit_cycle (ST_EXIT, EXEC_EXIT);
-}
-
-
-/* Match the CYCLE statement. */
-
-match
-gfc_match_cycle (void)
-{
- return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
-}
-
-
-/* Match a stop-code after an (ERROR) STOP or PAUSE statement. The
- requirements for a stop-code differ in the standards.
-
-Fortran 95 has
-
- R840 stop-stmt is STOP [ stop-code ]
- R841 stop-code is scalar-char-constant
- or digit [ digit [ digit [ digit [ digit ] ] ] ]
-
-Fortran 2003 matches Fortran 95 except R840 and R841 are now R849 and R850.
-Fortran 2008 has
-
- R855 stop-stmt is STOP [ stop-code ]
- R856 allstop-stmt is ALL STOP [ stop-code ]
- R857 stop-code is scalar-default-char-constant-expr
- or scalar-int-constant-expr
-
-For free-form source code, all standards contain a statement of the form:
-
- A blank shall be used to separate names, constants, or labels from
- adjacent keywords, names, constants, or labels.
-
-A stop-code is not a name, constant, or label. So, under Fortran 95 and 2003,
-
- STOP123
-
-is valid, but it is invalid Fortran 2008. */
-
-static match
-gfc_match_stopcode (gfc_statement st)
-{
- gfc_expr *e = NULL;
- match m;
- bool f95, f03, f08;
-
- /* Set f95 for -std=f95. */
- f95 = (gfc_option.allow_std == GFC_STD_OPT_F95);
-
- /* Set f03 for -std=f2003. */
- f03 = (gfc_option.allow_std == GFC_STD_OPT_F03);
-
- /* Set f08 for -std=f2008. */
- f08 = (gfc_option.allow_std == GFC_STD_OPT_F08);
-
- /* Look for a blank between STOP and the stop-code for F2008 or later. */
- if (gfc_current_form != FORM_FIXED && !(f95 || f03))
- {
- char c = gfc_peek_ascii_char ();
-
- /* Look for end-of-statement. There is no stop-code. */
- if (c == '\n' || c == '!' || c == ';')
- goto done;
-
- if (c != ' ')
- {
- gfc_error ("Blank required in %s statement near %C",
- gfc_ascii_statement (st));
- return MATCH_ERROR;
- }
- }
-
- if (gfc_match_eos () != MATCH_YES)
- {
- int stopcode;
- locus old_locus;
-
- /* First look for the F95 or F2003 digit [...] construct. */
- old_locus = gfc_current_locus;
- m = gfc_match_small_int (&stopcode);
- if (m == MATCH_YES && (f95 || f03))
- {
- if (stopcode < 0)
- {
- gfc_error ("STOP code at %C cannot be negative");
- return MATCH_ERROR;
- }
-
- if (stopcode > 99999)
- {
- gfc_error ("STOP code at %C contains too many digits");
- return MATCH_ERROR;
- }
- }
-
- /* Reset the locus and now load gfc_expr. */
- gfc_current_locus = old_locus;
- m = gfc_match_expr (&e);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_NO)
- goto syntax;
-
- if (gfc_match_eos () != MATCH_YES)
- goto syntax;
- }
-
- if (gfc_pure (NULL))
- {
- if (st == ST_ERROR_STOP)
- {
- if (!gfc_notify_std (GFC_STD_F2018, "%s statement at %C in PURE "
- "procedure", gfc_ascii_statement (st)))
- goto cleanup;
- }
- else
- {
- gfc_error ("%s statement not allowed in PURE procedure at %C",
- gfc_ascii_statement (st));
- goto cleanup;
- }
- }
-
- gfc_unset_implicit_pure (NULL);
-
- if (st == ST_STOP && gfc_find_state (COMP_CRITICAL))
- {
- gfc_error ("Image control statement STOP at %C in CRITICAL block");
- goto cleanup;
- }
- if (st == ST_STOP && gfc_find_state (COMP_DO_CONCURRENT))
- {
- gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
- goto cleanup;
- }
-
- if (e != NULL)
- {
- if (!gfc_simplify_expr (e, 0))
- goto cleanup;
-
- /* Test for F95 and F2003 style STOP stop-code. */
- if (e->expr_type != EXPR_CONSTANT && (f95 || f03))
- {
- gfc_error ("STOP code at %L must be a scalar CHARACTER constant "
- "or digit[digit[digit[digit[digit]]]]", &e->where);
- goto cleanup;
- }
-
- /* Use the machinery for an initialization expression to reduce the
- stop-code to a constant. */
- gfc_reduce_init_expr (e);
-
- /* Test for F2008 style STOP stop-code. */
- if (e->expr_type != EXPR_CONSTANT && f08)
- {
- gfc_error ("STOP code at %L must be a scalar default CHARACTER or "
- "INTEGER constant expression", &e->where);
- goto cleanup;
- }
-
- if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER))
- {
- gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
- &e->where);
- goto cleanup;
- }
-
- if (e->rank != 0)
- {
- gfc_error ("STOP code at %L must be scalar", &e->where);
- goto cleanup;
- }
-
- if (e->ts.type == BT_CHARACTER
- && e->ts.kind != gfc_default_character_kind)
- {
- gfc_error ("STOP code at %L must be default character KIND=%d",
- &e->where, (int) gfc_default_character_kind);
- goto cleanup;
- }
-
- if (e->ts.type == BT_INTEGER && e->ts.kind != gfc_default_integer_kind)
- {
- gfc_error ("STOP code at %L must be default integer KIND=%d",
- &e->where, (int) gfc_default_integer_kind);
- goto cleanup;
- }
- }
-
-done:
-
- switch (st)
- {
- case ST_STOP:
- new_st.op = EXEC_STOP;
- break;
- case ST_ERROR_STOP:
- new_st.op = EXEC_ERROR_STOP;
- break;
- case ST_PAUSE:
- new_st.op = EXEC_PAUSE;
- break;
- default:
- gcc_unreachable ();
- }
-
- new_st.expr1 = e;
- new_st.ext.stop_code = -1;
-
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (st);
-
-cleanup:
-
- gfc_free_expr (e);
- return MATCH_ERROR;
-}
-
-
-/* Match the (deprecated) PAUSE statement. */
-
-match
-gfc_match_pause (void)
-{
- match m;
-
- m = gfc_match_stopcode (ST_PAUSE);
- if (m == MATCH_YES)
- {
- if (!gfc_notify_std (GFC_STD_F95_DEL, "PAUSE statement at %C"))
- m = MATCH_ERROR;
- }
- return m;
-}
-
-
-/* Match the STOP statement. */
-
-match
-gfc_match_stop (void)
-{
- return gfc_match_stopcode (ST_STOP);
-}
-
-
-/* Match the ERROR STOP statement. */
-
-match
-gfc_match_error_stop (void)
-{
- if (!gfc_notify_std (GFC_STD_F2008, "ERROR STOP statement at %C"))
- return MATCH_ERROR;
-
- return gfc_match_stopcode (ST_ERROR_STOP);
-}
-
-/* Match EVENT POST/WAIT statement. Syntax:
- EVENT POST ( event-variable [, sync-stat-list] )
- EVENT WAIT ( event-variable [, wait-spec-list] )
- with
- wait-spec-list is sync-stat-list or until-spec
- until-spec is UNTIL_COUNT = scalar-int-expr
- sync-stat is STAT= or ERRMSG=. */
-
-static match
-event_statement (gfc_statement st)
-{
- match m;
- gfc_expr *tmp, *eventvar, *until_count, *stat, *errmsg;
- bool saw_until_count, saw_stat, saw_errmsg;
-
- tmp = eventvar = until_count = stat = errmsg = NULL;
- saw_until_count = saw_stat = saw_errmsg = false;
-
- if (gfc_pure (NULL))
- {
- gfc_error ("Image control statement EVENT %s at %C in PURE procedure",
- st == ST_EVENT_POST ? "POST" : "WAIT");
- return MATCH_ERROR;
- }
-
- gfc_unset_implicit_pure (NULL);
-
- if (flag_coarray == GFC_FCOARRAY_NONE)
- {
- gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
- return MATCH_ERROR;
- }
-
- if (gfc_find_state (COMP_CRITICAL))
- {
- gfc_error ("Image control statement EVENT %s at %C in CRITICAL block",
- st == ST_EVENT_POST ? "POST" : "WAIT");
- return MATCH_ERROR;
- }
-
- if (gfc_find_state (COMP_DO_CONCURRENT))
- {
- gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT "
- "block", st == ST_EVENT_POST ? "POST" : "WAIT");
- return MATCH_ERROR;
- }
-
- if (gfc_match_char ('(') != MATCH_YES)
- goto syntax;
-
- if (gfc_match ("%e", &eventvar) != MATCH_YES)
- goto syntax;
- m = gfc_match_char (',');
- if (m == MATCH_ERROR)
- goto syntax;
- if (m == MATCH_NO)
- {
- m = gfc_match_char (')');
- if (m == MATCH_YES)
- goto done;
- goto syntax;
- }
-
- for (;;)
- {
- m = gfc_match (" stat = %v", &tmp);
- if (m == MATCH_ERROR)
- goto syntax;
- if (m == MATCH_YES)
- {
- if (saw_stat)
- {
- gfc_error ("Redundant STAT tag found at %L", &tmp->where);
- goto cleanup;
- }
- stat = tmp;
- saw_stat = true;
-
- m = gfc_match_char (',');
- if (m == MATCH_YES)
- continue;
-
- tmp = NULL;
- break;
- }
-
- m = gfc_match (" errmsg = %v", &tmp);
- if (m == MATCH_ERROR)
- goto syntax;
- if (m == MATCH_YES)
- {
- if (saw_errmsg)
- {
- gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
- goto cleanup;
- }
- errmsg = tmp;
- saw_errmsg = true;
-
- m = gfc_match_char (',');
- if (m == MATCH_YES)
- continue;
-
- tmp = NULL;
- break;
- }
-
- m = gfc_match (" until_count = %e", &tmp);
- if (m == MATCH_ERROR || st == ST_EVENT_POST)
- goto syntax;
- if (m == MATCH_YES)
- {
- if (saw_until_count)
- {
- gfc_error ("Redundant UNTIL_COUNT tag found at %L",
- &tmp->where);
- goto cleanup;
- }
- until_count = tmp;
- saw_until_count = true;
-
- m = gfc_match_char (',');
- if (m == MATCH_YES)
- continue;
-
- tmp = NULL;
- break;
- }
-
- break;
- }
-
- if (m == MATCH_ERROR)
- goto syntax;
-
- if (gfc_match (" )%t") != MATCH_YES)
- goto syntax;
-
-done:
- switch (st)
- {
- case ST_EVENT_POST:
- new_st.op = EXEC_EVENT_POST;
- break;
- case ST_EVENT_WAIT:
- new_st.op = EXEC_EVENT_WAIT;
- break;
- default:
- gcc_unreachable ();
- }
-
- new_st.expr1 = eventvar;
- new_st.expr2 = stat;
- new_st.expr3 = errmsg;
- new_st.expr4 = until_count;
-
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (st);
-
-cleanup:
- if (until_count != tmp)
- gfc_free_expr (until_count);
- if (errmsg != tmp)
- gfc_free_expr (errmsg);
- if (stat != tmp)
- gfc_free_expr (stat);
-
- gfc_free_expr (tmp);
- gfc_free_expr (eventvar);
-
- return MATCH_ERROR;
-
-}
-
-
-match
-gfc_match_event_post (void)
-{
- if (!gfc_notify_std (GFC_STD_F2018, "EVENT POST statement at %C"))
- return MATCH_ERROR;
-
- return event_statement (ST_EVENT_POST);
-}
-
-
-match
-gfc_match_event_wait (void)
-{
- if (!gfc_notify_std (GFC_STD_F2018, "EVENT WAIT statement at %C"))
- return MATCH_ERROR;
-
- return event_statement (ST_EVENT_WAIT);
-}
-
-
-/* Match a FAIL IMAGE statement. */
-
-match
-gfc_match_fail_image (void)
-{
- if (!gfc_notify_std (GFC_STD_F2018, "FAIL IMAGE statement at %C"))
- return MATCH_ERROR;
-
- if (gfc_match_char ('(') == MATCH_YES)
- goto syntax;
-
- new_st.op = EXEC_FAIL_IMAGE;
-
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_FAIL_IMAGE);
-
- return MATCH_ERROR;
-}
-
-/* Match a FORM TEAM statement. */
-
-match
-gfc_match_form_team (void)
-{
- match m;
- gfc_expr *teamid,*team;
-
- if (!gfc_notify_std (GFC_STD_F2018, "FORM TEAM statement at %C"))
- return MATCH_ERROR;
-
- if (gfc_match_char ('(') == MATCH_NO)
- goto syntax;
-
- new_st.op = EXEC_FORM_TEAM;
-
- if (gfc_match ("%e", &teamid) != MATCH_YES)
- goto syntax;
- m = gfc_match_char (',');
- if (m == MATCH_ERROR)
- goto syntax;
- if (gfc_match ("%e", &team) != MATCH_YES)
- goto syntax;
-
- m = gfc_match_char (')');
- if (m == MATCH_NO)
- goto syntax;
-
- new_st.expr1 = teamid;
- new_st.expr2 = team;
-
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_FORM_TEAM);
-
- return MATCH_ERROR;
-}
-
-/* Match a CHANGE TEAM statement. */
-
-match
-gfc_match_change_team (void)
-{
- match m;
- gfc_expr *team;
-
- if (!gfc_notify_std (GFC_STD_F2018, "CHANGE TEAM statement at %C"))
- return MATCH_ERROR;
-
- if (gfc_match_char ('(') == MATCH_NO)
- goto syntax;
-
- new_st.op = EXEC_CHANGE_TEAM;
-
- if (gfc_match ("%e", &team) != MATCH_YES)
- goto syntax;
-
- m = gfc_match_char (')');
- if (m == MATCH_NO)
- goto syntax;
-
- new_st.expr1 = team;
-
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_CHANGE_TEAM);
-
- return MATCH_ERROR;
-}
-
-/* Match a END TEAM statement. */
-
-match
-gfc_match_end_team (void)
-{
- if (!gfc_notify_std (GFC_STD_F2018, "END TEAM statement at %C"))
- return MATCH_ERROR;
-
- if (gfc_match_char ('(') == MATCH_YES)
- goto syntax;
-
- new_st.op = EXEC_END_TEAM;
-
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_END_TEAM);
-
- return MATCH_ERROR;
-}
-
-/* Match a SYNC TEAM statement. */
-
-match
-gfc_match_sync_team (void)
-{
- match m;
- gfc_expr *team;
-
- if (!gfc_notify_std (GFC_STD_F2018, "SYNC TEAM statement at %C"))
- return MATCH_ERROR;
-
- if (gfc_match_char ('(') == MATCH_NO)
- goto syntax;
-
- new_st.op = EXEC_SYNC_TEAM;
-
- if (gfc_match ("%e", &team) != MATCH_YES)
- goto syntax;
-
- m = gfc_match_char (')');
- if (m == MATCH_NO)
- goto syntax;
-
- new_st.expr1 = team;
-
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_SYNC_TEAM);
-
- return MATCH_ERROR;
-}
-
-/* Match LOCK/UNLOCK statement. Syntax:
- LOCK ( lock-variable [ , lock-stat-list ] )
- UNLOCK ( lock-variable [ , sync-stat-list ] )
- where lock-stat is ACQUIRED_LOCK or sync-stat
- and sync-stat is STAT= or ERRMSG=. */
-
-static match
-lock_unlock_statement (gfc_statement st)
-{
- match m;
- gfc_expr *tmp, *lockvar, *acq_lock, *stat, *errmsg;
- bool saw_acq_lock, saw_stat, saw_errmsg;
-
- tmp = lockvar = acq_lock = stat = errmsg = NULL;
- saw_acq_lock = saw_stat = saw_errmsg = false;
-
- if (gfc_pure (NULL))
- {
- gfc_error ("Image control statement %s at %C in PURE procedure",
- st == ST_LOCK ? "LOCK" : "UNLOCK");
- return MATCH_ERROR;
- }
-
- gfc_unset_implicit_pure (NULL);
-
- if (flag_coarray == GFC_FCOARRAY_NONE)
- {
- gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
- return MATCH_ERROR;
- }
-
- if (gfc_find_state (COMP_CRITICAL))
- {
- gfc_error ("Image control statement %s at %C in CRITICAL block",
- st == ST_LOCK ? "LOCK" : "UNLOCK");
- return MATCH_ERROR;
- }
-
- if (gfc_find_state (COMP_DO_CONCURRENT))
- {
- gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
- st == ST_LOCK ? "LOCK" : "UNLOCK");
- return MATCH_ERROR;
- }
-
- if (gfc_match_char ('(') != MATCH_YES)
- goto syntax;
-
- if (gfc_match ("%e", &lockvar) != MATCH_YES)
- goto syntax;
- m = gfc_match_char (',');
- if (m == MATCH_ERROR)
- goto syntax;
- if (m == MATCH_NO)
- {
- m = gfc_match_char (')');
- if (m == MATCH_YES)
- goto done;
- goto syntax;
- }
-
- for (;;)
- {
- m = gfc_match (" stat = %v", &tmp);
- if (m == MATCH_ERROR)
- goto syntax;
- if (m == MATCH_YES)
- {
- if (saw_stat)
- {
- gfc_error ("Redundant STAT tag found at %L", &tmp->where);
- goto cleanup;
- }
- stat = tmp;
- saw_stat = true;
-
- m = gfc_match_char (',');
- if (m == MATCH_YES)
- continue;
-
- tmp = NULL;
- break;
- }
-
- m = gfc_match (" errmsg = %v", &tmp);
- if (m == MATCH_ERROR)
- goto syntax;
- if (m == MATCH_YES)
- {
- if (saw_errmsg)
- {
- gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
- goto cleanup;
- }
- errmsg = tmp;
- saw_errmsg = true;
-
- m = gfc_match_char (',');
- if (m == MATCH_YES)
- continue;
-
- tmp = NULL;
- break;
- }
-
- m = gfc_match (" acquired_lock = %v", &tmp);
- if (m == MATCH_ERROR || st == ST_UNLOCK)
- goto syntax;
- if (m == MATCH_YES)
- {
- if (saw_acq_lock)
- {
- gfc_error ("Redundant ACQUIRED_LOCK tag found at %L",
- &tmp->where);
- goto cleanup;
- }
- acq_lock = tmp;
- saw_acq_lock = true;
-
- m = gfc_match_char (',');
- if (m == MATCH_YES)
- continue;
-
- tmp = NULL;
- break;
- }
-
- break;
- }
-
- if (m == MATCH_ERROR)
- goto syntax;
-
- if (gfc_match (" )%t") != MATCH_YES)
- goto syntax;
-
-done:
- switch (st)
- {
- case ST_LOCK:
- new_st.op = EXEC_LOCK;
- break;
- case ST_UNLOCK:
- new_st.op = EXEC_UNLOCK;
- break;
- default:
- gcc_unreachable ();
- }
-
- new_st.expr1 = lockvar;
- new_st.expr2 = stat;
- new_st.expr3 = errmsg;
- new_st.expr4 = acq_lock;
-
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (st);
-
-cleanup:
- if (acq_lock != tmp)
- gfc_free_expr (acq_lock);
- if (errmsg != tmp)
- gfc_free_expr (errmsg);
- if (stat != tmp)
- gfc_free_expr (stat);
-
- gfc_free_expr (tmp);
- gfc_free_expr (lockvar);
-
- return MATCH_ERROR;
-}
-
-
-match
-gfc_match_lock (void)
-{
- if (!gfc_notify_std (GFC_STD_F2008, "LOCK statement at %C"))
- return MATCH_ERROR;
-
- return lock_unlock_statement (ST_LOCK);
-}
-
-
-match
-gfc_match_unlock (void)
-{
- if (!gfc_notify_std (GFC_STD_F2008, "UNLOCK statement at %C"))
- return MATCH_ERROR;
-
- return lock_unlock_statement (ST_UNLOCK);
-}
-
-
-/* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
- SYNC ALL [(sync-stat-list)]
- SYNC MEMORY [(sync-stat-list)]
- SYNC IMAGES (image-set [, sync-stat-list] )
- with sync-stat is int-expr or *. */
-
-static match
-sync_statement (gfc_statement st)
-{
- match m;
- gfc_expr *tmp, *imageset, *stat, *errmsg;
- bool saw_stat, saw_errmsg;
-
- tmp = imageset = stat = errmsg = NULL;
- saw_stat = saw_errmsg = false;
-
- if (gfc_pure (NULL))
- {
- gfc_error ("Image control statement SYNC at %C in PURE procedure");
- return MATCH_ERROR;
- }
-
- gfc_unset_implicit_pure (NULL);
-
- if (!gfc_notify_std (GFC_STD_F2008, "SYNC statement at %C"))
- return MATCH_ERROR;
-
- if (flag_coarray == GFC_FCOARRAY_NONE)
- {
- gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
- "enable");
- return MATCH_ERROR;
- }
-
- if (gfc_find_state (COMP_CRITICAL))
- {
- gfc_error ("Image control statement SYNC at %C in CRITICAL block");
- return MATCH_ERROR;
- }
-
- if (gfc_find_state (COMP_DO_CONCURRENT))
- {
- gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
- return MATCH_ERROR;
- }
-
- if (gfc_match_eos () == MATCH_YES)
- {
- if (st == ST_SYNC_IMAGES)
- goto syntax;
- goto done;
- }
-
- if (gfc_match_char ('(') != MATCH_YES)
- goto syntax;
-
- if (st == ST_SYNC_IMAGES)
- {
- /* Denote '*' as imageset == NULL. */
- m = gfc_match_char ('*');
- if (m == MATCH_ERROR)
- goto syntax;
- if (m == MATCH_NO)
- {
- if (gfc_match ("%e", &imageset) != MATCH_YES)
- goto syntax;
- }
- m = gfc_match_char (',');
- if (m == MATCH_ERROR)
- goto syntax;
- if (m == MATCH_NO)
- {
- m = gfc_match_char (')');
- if (m == MATCH_YES)
- goto done;
- goto syntax;
- }
- }
-
- for (;;)
- {
- m = gfc_match (" stat = %e", &tmp);
- if (m == MATCH_ERROR)
- goto syntax;
- if (m == MATCH_YES)
- {
- if (saw_stat)
- {
- gfc_error ("Redundant STAT tag found at %L", &tmp->where);
- goto cleanup;
- }
- stat = tmp;
- saw_stat = true;
-
- if (gfc_match_char (',') == MATCH_YES)
- continue;
-
- tmp = NULL;
- break;
- }
-
- m = gfc_match (" errmsg = %e", &tmp);
- if (m == MATCH_ERROR)
- goto syntax;
- if (m == MATCH_YES)
- {
- if (saw_errmsg)
- {
- gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
- goto cleanup;
- }
- errmsg = tmp;
- saw_errmsg = true;
-
- if (gfc_match_char (',') == MATCH_YES)
- continue;
-
- tmp = NULL;
- break;
- }
-
- break;
- }
-
- if (gfc_match (" )%t") != MATCH_YES)
- goto syntax;
-
-done:
- switch (st)
- {
- case ST_SYNC_ALL:
- new_st.op = EXEC_SYNC_ALL;
- break;
- case ST_SYNC_IMAGES:
- new_st.op = EXEC_SYNC_IMAGES;
- break;
- case ST_SYNC_MEMORY:
- new_st.op = EXEC_SYNC_MEMORY;
- break;
- default:
- gcc_unreachable ();
- }
-
- new_st.expr1 = imageset;
- new_st.expr2 = stat;
- new_st.expr3 = errmsg;
-
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (st);
-
-cleanup:
- if (stat != tmp)
- gfc_free_expr (stat);
- if (errmsg != tmp)
- gfc_free_expr (errmsg);
-
- gfc_free_expr (tmp);
- gfc_free_expr (imageset);
-
- return MATCH_ERROR;
-}
-
-
-/* Match SYNC ALL statement. */
-
-match
-gfc_match_sync_all (void)
-{
- return sync_statement (ST_SYNC_ALL);
-}
-
-
-/* Match SYNC IMAGES statement. */
-
-match
-gfc_match_sync_images (void)
-{
- return sync_statement (ST_SYNC_IMAGES);
-}
-
-
-/* Match SYNC MEMORY statement. */
-
-match
-gfc_match_sync_memory (void)
-{
- return sync_statement (ST_SYNC_MEMORY);
-}
-
-
-/* Match a CONTINUE statement. */
-
-match
-gfc_match_continue (void)
-{
- if (gfc_match_eos () != MATCH_YES)
- {
- gfc_syntax_error (ST_CONTINUE);
- return MATCH_ERROR;
- }
-
- new_st.op = EXEC_CONTINUE;
- return MATCH_YES;
-}
-
-
-/* Match the (deprecated) ASSIGN statement. */
-
-match
-gfc_match_assign (void)
-{
- gfc_expr *expr;
- gfc_st_label *label;
-
- if (gfc_match (" %l", &label) == MATCH_YES)
- {
- if (!gfc_reference_st_label (label, ST_LABEL_UNKNOWN))
- return MATCH_ERROR;
- if (gfc_match (" to %v%t", &expr) == MATCH_YES)
- {
- if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGN statement at %C"))
- return MATCH_ERROR;
-
- expr->symtree->n.sym->attr.assign = 1;
-
- new_st.op = EXEC_LABEL_ASSIGN;
- new_st.label1 = label;
- new_st.expr1 = expr;
- return MATCH_YES;
- }
- }
- return MATCH_NO;
-}
-
-
-/* Match the GO TO statement. As a computed GOTO statement is
- matched, it is transformed into an equivalent SELECT block. No
- tree is necessary, and the resulting jumps-to-jumps are
- specifically optimized away by the back end. */
-
-match
-gfc_match_goto (void)
-{
- gfc_code *head, *tail;
- gfc_expr *expr;
- gfc_case *cp;
- gfc_st_label *label;
- int i;
- match m;
-
- if (gfc_match (" %l%t", &label) == MATCH_YES)
- {
- if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
- return MATCH_ERROR;
-
- new_st.op = EXEC_GOTO;
- new_st.label1 = label;
- return MATCH_YES;
- }
-
- /* The assigned GO TO statement. */
-
- if (gfc_match_variable (&expr, 0) == MATCH_YES)
- {
- if (!gfc_notify_std (GFC_STD_F95_DEL, "Assigned GOTO statement at %C"))
- return MATCH_ERROR;
-
- new_st.op = EXEC_GOTO;
- new_st.expr1 = expr;
-
- if (gfc_match_eos () == MATCH_YES)
- return MATCH_YES;
-
- /* Match label list. */
- gfc_match_char (',');
- if (gfc_match_char ('(') != MATCH_YES)
- {
- gfc_syntax_error (ST_GOTO);
- return MATCH_ERROR;
- }
- head = tail = NULL;
-
- do
- {
- m = gfc_match_st_label (&label);
- if (m != MATCH_YES)
- goto syntax;
-
- if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
- goto cleanup;
-
- if (head == NULL)
- head = tail = gfc_get_code (EXEC_GOTO);
- else
- {
- tail->block = gfc_get_code (EXEC_GOTO);
- tail = tail->block;
- }
-
- tail->label1 = label;
- }
- while (gfc_match_char (',') == MATCH_YES);
-
- if (gfc_match (" )%t") != MATCH_YES)
- goto syntax;
-
- if (head == NULL)
- {
- gfc_error ("Statement label list in GOTO at %C cannot be empty");
- goto syntax;
- }
- new_st.block = head;
-
- return MATCH_YES;
- }
-
- /* Last chance is a computed GO TO statement. */
- if (gfc_match_char ('(') != MATCH_YES)
- {
- gfc_syntax_error (ST_GOTO);
- return MATCH_ERROR;
- }
-
- head = tail = NULL;
- i = 1;
-
- do
- {
- m = gfc_match_st_label (&label);
- if (m != MATCH_YES)
- goto syntax;
-
- if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
- goto cleanup;
-
- if (head == NULL)
- head = tail = gfc_get_code (EXEC_SELECT);
- else
- {
- tail->block = gfc_get_code (EXEC_SELECT);
- tail = tail->block;
- }
-
- cp = gfc_get_case ();
- cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind,
- NULL, i++);
-
- tail->ext.block.case_list = cp;
-
- tail->next = gfc_get_code (EXEC_GOTO);
- tail->next->label1 = label;
- }
- while (gfc_match_char (',') == MATCH_YES);
-
- if (gfc_match_char (')') != MATCH_YES)
- goto syntax;
-
- if (head == NULL)
- {
- gfc_error ("Statement label list in GOTO at %C cannot be empty");
- goto syntax;
- }
-
- /* Get the rest of the statement. */
- gfc_match_char (',');
-
- if (gfc_match (" %e%t", &expr) != MATCH_YES)
- goto syntax;
-
- if (!gfc_notify_std (GFC_STD_F95_OBS, "Computed GOTO at %C"))
- return MATCH_ERROR;
-
- /* At this point, a computed GOTO has been fully matched and an
- equivalent SELECT statement constructed. */
-
- new_st.op = EXEC_SELECT;
- new_st.expr1 = NULL;
-
- /* Hack: For a "real" SELECT, the expression is in expr. We put
- it in expr2 so we can distinguish then and produce the correct
- diagnostics. */
- new_st.expr2 = expr;
- new_st.block = head;
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_GOTO);
-cleanup:
- gfc_free_statements (head);
- return MATCH_ERROR;
-}
-
-
-/* Frees a list of gfc_alloc structures. */
-
-void
-gfc_free_alloc_list (gfc_alloc *p)
-{
- gfc_alloc *q;
-
- for (; p; p = q)
- {
- q = p->next;
- gfc_free_expr (p->expr);
- free (p);
- }
-}
-
-
-/* Match an ALLOCATE statement. */
-
-match
-gfc_match_allocate (void)
-{
- gfc_alloc *head, *tail;
- gfc_expr *stat, *errmsg, *tmp, *source, *mold;
- gfc_typespec ts;
- gfc_symbol *sym;
- match m;
- locus old_locus, deferred_locus, assumed_locus;
- bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
- bool saw_unlimited = false, saw_assumed = false;
-
- head = tail = NULL;
- stat = errmsg = source = mold = tmp = NULL;
- saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false;
-
- if (gfc_match_char ('(') != MATCH_YES)
- {
- gfc_syntax_error (ST_ALLOCATE);
- return MATCH_ERROR;
- }
-
- /* Match an optional type-spec. */
- old_locus = gfc_current_locus;
- m = gfc_match_type_spec (&ts);
- if (m == MATCH_ERROR)
- goto cleanup;
- else if (m == MATCH_NO)
- {
- char name[GFC_MAX_SYMBOL_LEN + 3];
-
- if (gfc_match ("%n :: ", name) == MATCH_YES)
- {
- gfc_error ("Error in type-spec at %L", &old_locus);
- goto cleanup;
- }
-
- ts.type = BT_UNKNOWN;
- }
- else
- {
- /* Needed for the F2008:C631 check below. */
- assumed_locus = gfc_current_locus;
-
- if (gfc_match (" :: ") == MATCH_YES)
- {
- if (!gfc_notify_std (GFC_STD_F2003, "typespec in ALLOCATE at %L",
- &old_locus))
- goto cleanup;
-
- if (ts.deferred)
- {
- gfc_error ("Type-spec at %L cannot contain a deferred "
- "type parameter", &old_locus);
- goto cleanup;
- }
-
- if (ts.type == BT_CHARACTER)
- {
- if (!ts.u.cl->length)
- saw_assumed = true;
- else
- ts.u.cl->length_from_typespec = true;
- }
-
- if (type_param_spec_list
- && gfc_spec_list_type (type_param_spec_list, NULL)
- == SPEC_DEFERRED)
- {
- gfc_error ("The type parameter spec list in the type-spec at "
- "%L cannot contain DEFERRED parameters", &old_locus);
- goto cleanup;
- }
- }
- else
- {
- ts.type = BT_UNKNOWN;
- gfc_current_locus = old_locus;
- }
- }
-
- for (;;)
- {
- if (head == NULL)
- head = tail = gfc_get_alloc ();
- else
- {
- tail->next = gfc_get_alloc ();
- tail = tail->next;
- }
-
- m = gfc_match_variable (&tail->expr, 0);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- if (tail->expr->expr_type == EXPR_CONSTANT)
- {
- gfc_error ("Unexpected constant at %C");
- goto cleanup;
- }
-
- if (gfc_check_do_variable (tail->expr->symtree))
- goto cleanup;
-
- bool impure = gfc_impure_variable (tail->expr->symtree->n.sym);
- if (impure && gfc_pure (NULL))
- {
- gfc_error ("Bad allocate-object at %C for a PURE procedure");
- goto cleanup;
- }
-
- if (impure)
- gfc_unset_implicit_pure (NULL);
-
- /* F2008:C631 (R626) A type-param-value in a type-spec shall be an
- asterisk if and only if each allocate-object is a dummy argument
- for which the corresponding type parameter is assumed. */
- if (saw_assumed
- && (tail->expr->ts.deferred
- || (tail->expr->ts.u.cl && tail->expr->ts.u.cl->length)
- || tail->expr->symtree->n.sym->attr.dummy == 0))
- {
- gfc_error ("Incompatible allocate-object at %C for CHARACTER "
- "type-spec at %L", &assumed_locus);
- goto cleanup;
- }
-
- if (tail->expr->ts.deferred)
- {
- saw_deferred = true;
- deferred_locus = tail->expr->where;
- }
-
- if (gfc_find_state (COMP_DO_CONCURRENT)
- || gfc_find_state (COMP_CRITICAL))
- {
- gfc_ref *ref;
- bool coarray = tail->expr->symtree->n.sym->attr.codimension;
- for (ref = tail->expr->ref; ref; ref = ref->next)
- if (ref->type == REF_COMPONENT)
- coarray = ref->u.c.component->attr.codimension;
-
- if (coarray && gfc_find_state (COMP_DO_CONCURRENT))
- {
- gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
- goto cleanup;
- }
- if (coarray && gfc_find_state (COMP_CRITICAL))
- {
- gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
- goto cleanup;
- }
- }
-
- /* Check for F08:C628. */
- sym = tail->expr->symtree->n.sym;
- b1 = !(tail->expr->ref
- && (tail->expr->ref->type == REF_COMPONENT
- || tail->expr->ref->type == REF_ARRAY));
- if (sym && sym->ts.type == BT_CLASS && sym->attr.class_ok)
- b2 = !(CLASS_DATA (sym)->attr.allocatable
- || CLASS_DATA (sym)->attr.class_pointer);
- else
- b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
- || sym->attr.proc_pointer);
- b3 = sym && sym->ns && sym->ns->proc_name
- && (sym->ns->proc_name->attr.allocatable
- || sym->ns->proc_name->attr.pointer
- || sym->ns->proc_name->attr.proc_pointer);
- if (b1 && b2 && !b3)
- {
- gfc_error ("Allocate-object at %L is neither a data pointer "
- "nor an allocatable variable", &tail->expr->where);
- goto cleanup;
- }
-
- /* The ALLOCATE statement had an optional typespec. Check the
- constraints. */
- if (ts.type != BT_UNKNOWN)
- {
- /* Enforce F03:C624. */
- if (!gfc_type_compatible (&tail->expr->ts, &ts))
- {
- gfc_error ("Type of entity at %L is type incompatible with "
- "typespec", &tail->expr->where);
- goto cleanup;
- }
-
- /* Enforce F03:C627. */
- if (ts.kind != tail->expr->ts.kind && !UNLIMITED_POLY (tail->expr))
- {
- gfc_error ("Kind type parameter for entity at %L differs from "
- "the kind type parameter of the typespec",
- &tail->expr->where);
- goto cleanup;
- }
- }
-
- if (tail->expr->ts.type == BT_DERIVED)
- tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
-
- if (type_param_spec_list)
- tail->expr->param_list = gfc_copy_actual_arglist (type_param_spec_list);
-
- saw_unlimited = saw_unlimited | UNLIMITED_POLY (tail->expr);
-
- if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
- {
- gfc_error ("Shape specification for allocatable scalar at %C");
- goto cleanup;
- }
-
- if (gfc_match_char (',') != MATCH_YES)
- break;
-
-alloc_opt_list:
-
- m = gfc_match (" stat = %e", &tmp);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_YES)
- {
- /* Enforce C630. */
- if (saw_stat)
- {
- gfc_error ("Redundant STAT tag found at %L", &tmp->where);
- goto cleanup;
- }
-
- stat = tmp;
- tmp = NULL;
- saw_stat = true;
-
- if (stat->expr_type == EXPR_CONSTANT)
- {
- gfc_error ("STAT tag at %L cannot be a constant", &stat->where);
- goto cleanup;
- }
-
- if (gfc_check_do_variable (stat->symtree))
- goto cleanup;
-
- if (gfc_match_char (',') == MATCH_YES)
- goto alloc_opt_list;
- }
-
- m = gfc_match (" errmsg = %e", &tmp);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_YES)
- {
- if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG tag at %L", &tmp->where))
- goto cleanup;
-
- /* Enforce C630. */
- if (saw_errmsg)
- {
- gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
- goto cleanup;
- }
-
- errmsg = tmp;
- tmp = NULL;
- saw_errmsg = true;
-
- if (gfc_match_char (',') == MATCH_YES)
- goto alloc_opt_list;
- }
-
- m = gfc_match (" source = %e", &tmp);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_YES)
- {
- if (!gfc_notify_std (GFC_STD_F2003, "SOURCE tag at %L", &tmp->where))
- goto cleanup;
-
- /* Enforce C630. */
- if (saw_source)
- {
- gfc_error ("Redundant SOURCE tag found at %L", &tmp->where);
- goto cleanup;
- }
-
- /* The next 2 conditionals check C631. */
- if (ts.type != BT_UNKNOWN)
- {
- gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
- &tmp->where, &old_locus);
- goto cleanup;
- }
-
- if (head->next
- && !gfc_notify_std (GFC_STD_F2008, "SOURCE tag at %L"
- " with more than a single allocate object",
- &tmp->where))
- goto cleanup;
-
- source = tmp;
- tmp = NULL;
- saw_source = true;
-
- if (gfc_match_char (',') == MATCH_YES)
- goto alloc_opt_list;
- }
-
- m = gfc_match (" mold = %e", &tmp);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_YES)
- {
- if (!gfc_notify_std (GFC_STD_F2008, "MOLD tag at %L", &tmp->where))
- goto cleanup;
-
- /* Check F08:C636. */
- if (saw_mold)
- {
- gfc_error ("Redundant MOLD tag found at %L", &tmp->where);
- goto cleanup;
- }
-
- /* Check F08:C637. */
- if (ts.type != BT_UNKNOWN)
- {
- gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
- &tmp->where, &old_locus);
- goto cleanup;
- }
-
- mold = tmp;
- tmp = NULL;
- saw_mold = true;
- mold->mold = 1;
-
- if (gfc_match_char (',') == MATCH_YES)
- goto alloc_opt_list;
- }
-
- gfc_gobble_whitespace ();
-
- if (gfc_peek_char () == ')')
- break;
- }
-
- if (gfc_match (" )%t") != MATCH_YES)
- goto syntax;
-
- /* Check F08:C637. */
- if (source && mold)
- {
- gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
- &mold->where, &source->where);
- goto cleanup;
- }
-
- /* Check F03:C623, */
- if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold)
- {
- gfc_error ("Allocate-object at %L with a deferred type parameter "
- "requires either a type-spec or SOURCE tag or a MOLD tag",
- &deferred_locus);
- goto cleanup;
- }
-
- /* Check F03:C625, */
- if (saw_unlimited && ts.type == BT_UNKNOWN && !source && !mold)
- {
- for (tail = head; tail; tail = tail->next)
- {
- if (UNLIMITED_POLY (tail->expr))
- gfc_error ("Unlimited polymorphic allocate-object at %L "
- "requires either a type-spec or SOURCE tag "
- "or a MOLD tag", &tail->expr->where);
- }
- goto cleanup;
- }
-
- new_st.op = EXEC_ALLOCATE;
- new_st.expr1 = stat;
- new_st.expr2 = errmsg;
- if (source)
- new_st.expr3 = source;
- else
- new_st.expr3 = mold;
- new_st.ext.alloc.list = head;
- new_st.ext.alloc.ts = ts;
-
- if (type_param_spec_list)
- gfc_free_actual_arglist (type_param_spec_list);
-
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_ALLOCATE);
-
-cleanup:
- gfc_free_expr (errmsg);
- gfc_free_expr (source);
- gfc_free_expr (stat);
- gfc_free_expr (mold);
- if (tmp && tmp->expr_type) gfc_free_expr (tmp);
- gfc_free_alloc_list (head);
- if (type_param_spec_list)
- gfc_free_actual_arglist (type_param_spec_list);
- return MATCH_ERROR;
-}
-
-
-/* Match a NULLIFY statement. A NULLIFY statement is transformed into
- a set of pointer assignments to intrinsic NULL(). */
-
-match
-gfc_match_nullify (void)
-{
- gfc_code *tail;
- gfc_expr *e, *p;
- match m;
-
- tail = NULL;
-
- if (gfc_match_char ('(') != MATCH_YES)
- goto syntax;
-
- for (;;)
- {
- m = gfc_match_variable (&p, 0);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_NO)
- goto syntax;
-
- if (gfc_check_do_variable (p->symtree))
- goto cleanup;
-
- /* F2008, C1242. */
- if (gfc_is_coindexed (p))
- {
- gfc_error ("Pointer object at %C shall not be coindexed");
- goto cleanup;
- }
-
- /* Check for valid array pointer object. Bounds remapping is not
- allowed with NULLIFY. */
- if (p->ref)
- {
- gfc_ref *remap = p->ref;
- for (; remap; remap = remap->next)
- if (!remap->next && remap->type == REF_ARRAY
- && remap->u.ar.type != AR_FULL)
- break;
- if (remap)
- {
- gfc_error ("NULLIFY does not allow bounds remapping for "
- "pointer object at %C");
- goto cleanup;
- }
- }
-
- /* build ' => NULL() '. */
- e = gfc_get_null_expr (&gfc_current_locus);
-
- /* Chain to list. */
- if (tail == NULL)
- {
- tail = &new_st;
- tail->op = EXEC_POINTER_ASSIGN;
- }
- else
- {
- tail->next = gfc_get_code (EXEC_POINTER_ASSIGN);
- tail = tail->next;
- }
-
- tail->expr1 = p;
- tail->expr2 = e;
-
- if (gfc_match (" )%t") == MATCH_YES)
- break;
- if (gfc_match_char (',') != MATCH_YES)
- goto syntax;
- }
-
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_NULLIFY);
-
-cleanup:
- gfc_free_statements (new_st.next);
- new_st.next = NULL;
- gfc_free_expr (new_st.expr1);
- new_st.expr1 = NULL;
- gfc_free_expr (new_st.expr2);
- new_st.expr2 = NULL;
- return MATCH_ERROR;
-}
-
-
-/* Match a DEALLOCATE statement. */
-
-match
-gfc_match_deallocate (void)
-{
- gfc_alloc *head, *tail;
- gfc_expr *stat, *errmsg, *tmp;
- gfc_symbol *sym;
- match m;
- bool saw_stat, saw_errmsg, b1, b2;
-
- head = tail = NULL;
- stat = errmsg = tmp = NULL;
- saw_stat = saw_errmsg = false;
-
- if (gfc_match_char ('(') != MATCH_YES)
- goto syntax;
-
- for (;;)
- {
- if (head == NULL)
- head = tail = gfc_get_alloc ();
- else
- {
- tail->next = gfc_get_alloc ();
- tail = tail->next;
- }
-
- m = gfc_match_variable (&tail->expr, 0);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_NO)
- goto syntax;
-
- if (tail->expr->expr_type == EXPR_CONSTANT)
- {
- gfc_error ("Unexpected constant at %C");
- goto cleanup;
- }
-
- if (gfc_check_do_variable (tail->expr->symtree))
- goto cleanup;
-
- sym = tail->expr->symtree->n.sym;
-
- bool impure = gfc_impure_variable (sym);
- if (impure && gfc_pure (NULL))
- {
- gfc_error ("Illegal allocate-object at %C for a PURE procedure");
- goto cleanup;
- }
-
- if (impure)
- gfc_unset_implicit_pure (NULL);
-
- if (gfc_is_coarray (tail->expr)
- && gfc_find_state (COMP_DO_CONCURRENT))
- {
- gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
- goto cleanup;
- }
-
- if (gfc_is_coarray (tail->expr)
- && gfc_find_state (COMP_CRITICAL))
- {
- gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
- goto cleanup;
- }
-
- /* FIXME: disable the checking on derived types. */
- b1 = !(tail->expr->ref
- && (tail->expr->ref->type == REF_COMPONENT
- || tail->expr->ref->type == REF_ARRAY));
- if (sym && sym->ts.type == BT_CLASS)
- b2 = !(CLASS_DATA (sym) && (CLASS_DATA (sym)->attr.allocatable
- || CLASS_DATA (sym)->attr.class_pointer));
- else
- b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
- || sym->attr.proc_pointer);
- if (b1 && b2)
- {
- gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
- "nor an allocatable variable");
- goto cleanup;
- }
-
- if (gfc_match_char (',') != MATCH_YES)
- break;
-
-dealloc_opt_list:
-
- m = gfc_match (" stat = %e", &tmp);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_YES)
- {
- if (saw_stat)
- {
- gfc_error ("Redundant STAT tag found at %L", &tmp->where);
- gfc_free_expr (tmp);
- goto cleanup;
- }
-
- stat = tmp;
- saw_stat = true;
-
- if (gfc_check_do_variable (stat->symtree))
- goto cleanup;
-
- if (gfc_match_char (',') == MATCH_YES)
- goto dealloc_opt_list;
- }
-
- m = gfc_match (" errmsg = %e", &tmp);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_YES)
- {
- if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG at %L", &tmp->where))
- goto cleanup;
-
- if (saw_errmsg)
- {
- gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
- gfc_free_expr (tmp);
- goto cleanup;
- }
-
- errmsg = tmp;
- saw_errmsg = true;
-
- if (gfc_match_char (',') == MATCH_YES)
- goto dealloc_opt_list;
- }
-
- gfc_gobble_whitespace ();
-
- if (gfc_peek_char () == ')')
- break;
- }
-
- if (gfc_match (" )%t") != MATCH_YES)
- goto syntax;
-
- new_st.op = EXEC_DEALLOCATE;
- new_st.expr1 = stat;
- new_st.expr2 = errmsg;
- new_st.ext.alloc.list = head;
-
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_DEALLOCATE);
-
-cleanup:
- gfc_free_expr (errmsg);
- gfc_free_expr (stat);
- gfc_free_alloc_list (head);
- return MATCH_ERROR;
-}
-
-
-/* Match a RETURN statement. */
-
-match
-gfc_match_return (void)
-{
- gfc_expr *e;
- match m;
- gfc_compile_state s;
-
- e = NULL;
-
- if (gfc_find_state (COMP_CRITICAL))
- {
- gfc_error ("Image control statement RETURN at %C in CRITICAL block");
- return MATCH_ERROR;
- }
-
- if (gfc_find_state (COMP_DO_CONCURRENT))
- {
- gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
- return MATCH_ERROR;
- }
-
- if (gfc_match_eos () == MATCH_YES)
- goto done;
-
- if (!gfc_find_state (COMP_SUBROUTINE))
- {
- gfc_error ("Alternate RETURN statement at %C is only allowed within "
- "a SUBROUTINE");
- goto cleanup;
- }
-
- if (gfc_current_form == FORM_FREE)
- {
- /* The following are valid, so we can't require a blank after the
- RETURN keyword:
- return+1
- return(1) */
- char c = gfc_peek_ascii_char ();
- if (ISALPHA (c) || ISDIGIT (c))
- return MATCH_NO;
- }
-
- m = gfc_match (" %e%t", &e);
- if (m == MATCH_YES)
- goto done;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- gfc_syntax_error (ST_RETURN);
-
-cleanup:
- gfc_free_expr (e);
- return MATCH_ERROR;
-
-done:
- gfc_enclosing_unit (&s);
- if (s == COMP_PROGRAM
- && !gfc_notify_std (GFC_STD_GNU, "RETURN statement in "
- "main program at %C"))
- return MATCH_ERROR;
-
- new_st.op = EXEC_RETURN;
- new_st.expr1 = e;
-
- return MATCH_YES;
-}
-
-
-/* Match the call of a type-bound procedure, if CALL%var has already been
- matched and var found to be a derived-type variable. */
-
-static match
-match_typebound_call (gfc_symtree* varst)
-{
- gfc_expr* base;
- match m;
-
- base = gfc_get_expr ();
- base->expr_type = EXPR_VARIABLE;
- base->symtree = varst;
- base->where = gfc_current_locus;
- gfc_set_sym_referenced (varst->n.sym);
-
- m = gfc_match_varspec (base, 0, true, true);
- if (m == MATCH_NO)
- gfc_error ("Expected component reference at %C");
- if (m != MATCH_YES)
- {
- gfc_free_expr (base);
- return MATCH_ERROR;
- }
-
- if (gfc_match_eos () != MATCH_YES)
- {
- gfc_error ("Junk after CALL at %C");
- gfc_free_expr (base);
- return MATCH_ERROR;
- }
-
- if (base->expr_type == EXPR_COMPCALL)
- new_st.op = EXEC_COMPCALL;
- else if (base->expr_type == EXPR_PPC)
- new_st.op = EXEC_CALL_PPC;
- else
- {
- gfc_error ("Expected type-bound procedure or procedure pointer component "
- "at %C");
- gfc_free_expr (base);
- return MATCH_ERROR;
- }
- new_st.expr1 = base;
-
- return MATCH_YES;
-}
-
-
-/* Match a CALL statement. The tricky part here are possible
- alternate return specifiers. We handle these by having all
- "subroutines" actually return an integer via a register that gives
- the return number. If the call specifies alternate returns, we
- generate code for a SELECT statement whose case clauses contain
- GOTOs to the various labels. */
-
-match
-gfc_match_call (void)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_actual_arglist *a, *arglist;
- gfc_case *new_case;
- gfc_symbol *sym;
- gfc_symtree *st;
- gfc_code *c;
- match m;
- int i;
-
- arglist = NULL;
-
- m = gfc_match ("% %n", name);
- if (m == MATCH_NO)
- goto syntax;
- if (m != MATCH_YES)
- return m;
-
- if (gfc_get_ha_sym_tree (name, &st))
- return MATCH_ERROR;
-
- sym = st->n.sym;
-
- /* If this is a variable of derived-type, it probably starts a type-bound
- procedure call. Associate variable targets have to be resolved for the
- target type. */
- if (((sym->attr.flavor != FL_PROCEDURE
- || gfc_is_function_return_value (sym, gfc_current_ns))
- && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
- ||
- (sym->assoc && sym->assoc->target
- && gfc_resolve_expr (sym->assoc->target)
- && (sym->assoc->target->ts.type == BT_DERIVED
- || sym->assoc->target->ts.type == BT_CLASS)))
- return match_typebound_call (st);
-
- /* If it does not seem to be callable (include functions so that the
- right association is made. They are thrown out in resolution.)
- ... */
- if (!sym->attr.generic
- && !sym->attr.subroutine
- && !sym->attr.function)
- {
- if (!(sym->attr.external && !sym->attr.referenced))
- {
- /* ...create a symbol in this scope... */
- if (sym->ns != gfc_current_ns
- && gfc_get_sym_tree (name, NULL, &st, false) == 1)
- return MATCH_ERROR;
-
- if (sym != st->n.sym)
- sym = st->n.sym;
- }
-
- /* ...and then to try to make the symbol into a subroutine. */
- if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
- return MATCH_ERROR;
- }
-
- gfc_set_sym_referenced (sym);
-
- if (gfc_match_eos () != MATCH_YES)
- {
- m = gfc_match_actual_arglist (1, &arglist);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- if (gfc_match_eos () != MATCH_YES)
- goto syntax;
- }
-
- /* Walk the argument list looking for invalid BOZ. */
- for (a = arglist; a; a = a->next)
- if (a->expr && a->expr->ts.type == BT_BOZ)
- {
- gfc_error ("A BOZ literal constant at %L cannot appear as an actual "
- "argument in a subroutine reference", &a->expr->where);
- goto cleanup;
- }
-
-
- /* If any alternate return labels were found, construct a SELECT
- statement that will jump to the right place. */
-
- i = 0;
- for (a = arglist; a; a = a->next)
- if (a->expr == NULL)
- {
- i = 1;
- break;
- }
-
- if (i)
- {
- gfc_symtree *select_st;
- gfc_symbol *select_sym;
- char name[GFC_MAX_SYMBOL_LEN + 1];
-
- new_st.next = c = gfc_get_code (EXEC_SELECT);
- sprintf (name, "_result_%s", sym->name);
- gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */
-
- select_sym = select_st->n.sym;
- select_sym->ts.type = BT_INTEGER;
- select_sym->ts.kind = gfc_default_integer_kind;
- gfc_set_sym_referenced (select_sym);
- c->expr1 = gfc_get_expr ();
- c->expr1->expr_type = EXPR_VARIABLE;
- c->expr1->symtree = select_st;
- c->expr1->ts = select_sym->ts;
- c->expr1->where = gfc_current_locus;
-
- i = 0;
- for (a = arglist; a; a = a->next)
- {
- if (a->expr != NULL)
- continue;
-
- if (!gfc_reference_st_label (a->label, ST_LABEL_TARGET))
- continue;
-
- i++;
-
- c->block = gfc_get_code (EXEC_SELECT);
- c = c->block;
-
- new_case = gfc_get_case ();
- new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i);
- new_case->low = new_case->high;
- c->ext.block.case_list = new_case;
-
- c->next = gfc_get_code (EXEC_GOTO);
- c->next->label1 = a->label;
- }
- }
-
- new_st.op = EXEC_CALL;
- new_st.symtree = st;
- new_st.ext.actual = arglist;
-
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_CALL);
-
-cleanup:
- gfc_free_actual_arglist (arglist);
- return MATCH_ERROR;
-}
-
-
-/* Given a name, return a pointer to the common head structure,
- creating it if it does not exist. If FROM_MODULE is nonzero, we
- mangle the name so that it doesn't interfere with commons defined
- in the using namespace.
- TODO: Add to global symbol tree. */
-
-gfc_common_head *
-gfc_get_common (const char *name, int from_module)
-{
- gfc_symtree *st;
- static int serial = 0;
- char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
-
- if (from_module)
- {
- /* A use associated common block is only needed to correctly layout
- the variables it contains. */
- snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
- st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
- }
- else
- {
- st = gfc_find_symtree (gfc_current_ns->common_root, name);
-
- if (st == NULL)
- st = gfc_new_symtree (&gfc_current_ns->common_root, name);
- }
-
- if (st->n.common == NULL)
- {
- st->n.common = gfc_get_common_head ();
- st->n.common->where = gfc_current_locus;
- strcpy (st->n.common->name, name);
- }
-
- return st->n.common;
-}
-
-
-/* Match a common block name. */
-
-match
-gfc_match_common_name (char *name)
-{
- match m;
-
- if (gfc_match_char ('/') == MATCH_NO)
- {
- name[0] = '\0';
- return MATCH_YES;
- }
-
- if (gfc_match_char ('/') == MATCH_YES)
- {
- name[0] = '\0';
- return MATCH_YES;
- }
-
- m = gfc_match_name (name);
-
- if (m == MATCH_ERROR)
- return MATCH_ERROR;
- if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
- return MATCH_YES;
-
- gfc_error ("Syntax error in common block name at %C");
- return MATCH_ERROR;
-}
-
-
-/* Match a COMMON statement. */
-
-match
-gfc_match_common (void)
-{
- gfc_symbol *sym, **head, *tail, *other;
- char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_common_head *t;
- gfc_array_spec *as;
- gfc_equiv *e1, *e2;
- match m;
- char c;
-
- /* COMMON has been matched. In free form source code, the next character
- needs to be whitespace or '/'. Check that here. Fixed form source
- code needs to be checked below. */
- c = gfc_peek_ascii_char ();
- if (gfc_current_form == FORM_FREE && !gfc_is_whitespace (c) && c != '/')
- return MATCH_NO;
-
- as = NULL;
-
- for (;;)
- {
- m = gfc_match_common_name (name);
- if (m == MATCH_ERROR)
- goto cleanup;
-
- if (name[0] == '\0')
- {
- t = &gfc_current_ns->blank_common;
- if (t->head == NULL)
- t->where = gfc_current_locus;
- }
- else
- {
- t = gfc_get_common (name, 0);
- }
- head = &t->head;
-
- if (*head == NULL)
- tail = NULL;
- else
- {
- tail = *head;
- while (tail->common_next)
- tail = tail->common_next;
- }
-
- /* Grab the list of symbols. */
- for (;;)
- {
- m = gfc_match_symbol (&sym, 0);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_NO)
- goto syntax;
-
- /* See if we know the current common block is bind(c), and if
- so, then see if we can check if the symbol is (which it'll
- need to be). This can happen if the bind(c) attr stmt was
- applied to the common block, and the variable(s) already
- defined, before declaring the common block. */
- if (t->is_bind_c == 1)
- {
- if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
- {
- /* If we find an error, just print it and continue,
- cause it's just semantic, and we can see if there
- are more errors. */
- gfc_error_now ("Variable %qs at %L in common block %qs "
- "at %C must be declared with a C "
- "interoperable kind since common block "
- "%qs is bind(c)",
- sym->name, &(sym->declared_at), t->name,
- t->name);
- }
-
- if (sym->attr.is_bind_c == 1)
- gfc_error_now ("Variable %qs in common block %qs at %C cannot "
- "be bind(c) since it is not global", sym->name,
- t->name);
- }
-
- if (sym->attr.in_common)
- {
- gfc_error ("Symbol %qs at %C is already in a COMMON block",
- sym->name);
- goto cleanup;
- }
-
- if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
- || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
- {
- if (!gfc_notify_std (GFC_STD_GNU, "Initialized symbol %qs at "
- "%C can only be COMMON in BLOCK DATA",
- sym->name))
- goto cleanup;
- }
-
- /* Deal with an optional array specification after the
- symbol name. */
- m = gfc_match_array_spec (&as, true, true);
- if (m == MATCH_ERROR)
- goto cleanup;
-
- if (m == MATCH_YES)
- {
- if (as->type != AS_EXPLICIT)
- {
- gfc_error ("Array specification for symbol %qs in COMMON "
- "at %C must be explicit", sym->name);
- goto cleanup;
- }
-
- if (as->corank)
- {
- gfc_error ("Symbol %qs in COMMON at %C cannot be a "
- "coarray", sym->name);
- goto cleanup;
- }
-
- if (!gfc_add_dimension (&sym->attr, sym->name, NULL))
- goto cleanup;
-
- if (sym->attr.pointer)
- {
- gfc_error ("Symbol %qs in COMMON at %C cannot be a "
- "POINTER array", sym->name);
- goto cleanup;
- }
-
- sym->as = as;
- as = NULL;
-
- }
-
- /* Add the in_common attribute, but ignore the reported errors
- if any, and continue matching. */
- gfc_add_in_common (&sym->attr, sym->name, NULL);
-
- sym->common_block = t;
- sym->common_block->refs++;
-
- if (tail != NULL)
- tail->common_next = sym;
- else
- *head = sym;
-
- tail = sym;
-
- sym->common_head = t;
-
- /* Check to see if the symbol is already in an equivalence group.
- If it is, set the other members as being in common. */
- if (sym->attr.in_equivalence)
- {
- for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
- {
- for (e2 = e1; e2; e2 = e2->eq)
- if (e2->expr->symtree->n.sym == sym)
- goto equiv_found;
-
- continue;
-
- equiv_found:
-
- for (e2 = e1; e2; e2 = e2->eq)
- {
- other = e2->expr->symtree->n.sym;
- if (other->common_head
- && other->common_head != sym->common_head)
- {
- gfc_error ("Symbol %qs, in COMMON block %qs at "
- "%C is being indirectly equivalenced to "
- "another COMMON block %qs",
- sym->name, sym->common_head->name,
- other->common_head->name);
- goto cleanup;
- }
- other->attr.in_common = 1;
- other->common_head = t;
- }
- }
- }
-
-
- gfc_gobble_whitespace ();
- if (gfc_match_eos () == MATCH_YES)
- goto done;
- c = gfc_peek_ascii_char ();
- if (c == '/')
- break;
- if (c != ',')
- {
- /* In Fixed form source code, gfortran can end up here for an
- expression of the form COMMONI = RHS. This may not be an
- error, so return MATCH_NO. */
- if (gfc_current_form == FORM_FIXED && c == '=')
- {
- gfc_free_array_spec (as);
- return MATCH_NO;
- }
- goto syntax;
- }
- else
- gfc_match_char (',');
-
- gfc_gobble_whitespace ();
- if (gfc_peek_ascii_char () == '/')
- break;
- }
- }
-
-done:
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_COMMON);
-
-cleanup:
- gfc_free_array_spec (as);
- return MATCH_ERROR;
-}
-
-
-/* Match a BLOCK DATA program unit. */
-
-match
-gfc_match_block_data (void)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_symbol *sym;
- match m;
-
- if (!gfc_notify_std (GFC_STD_F2018_OBS, "BLOCK DATA construct at %L",
- &gfc_current_locus))
- return MATCH_ERROR;
-
- if (gfc_match_eos () == MATCH_YES)
- {
- gfc_new_block = NULL;
- return MATCH_YES;
- }
-
- m = gfc_match ("% %n%t", name);
- if (m != MATCH_YES)
- return MATCH_ERROR;
-
- if (gfc_get_symbol (name, NULL, &sym))
- return MATCH_ERROR;
-
- if (!gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL))
- return MATCH_ERROR;
-
- gfc_new_block = sym;
-
- return MATCH_YES;
-}
-
-
-/* Free a namelist structure. */
-
-void
-gfc_free_namelist (gfc_namelist *name)
-{
- gfc_namelist *n;
-
- for (; name; name = n)
- {
- n = name->next;
- free (name);
- }
-}
-
-
-/* Free an OpenMP namelist structure. */
-
-void
-gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns)
-{
- gfc_omp_namelist *n;
-
- for (; name; name = n)
- {
- gfc_free_expr (name->expr);
- if (free_ns)
- gfc_free_namespace (name->u2.ns);
- else if (name->u2.udr)
- {
- if (name->u2.udr->combiner)
- gfc_free_statement (name->u2.udr->combiner);
- if (name->u2.udr->initializer)
- gfc_free_statement (name->u2.udr->initializer);
- free (name->u2.udr);
- }
- n = name->next;
- free (name);
- }
-}
-
-
-/* Match a NAMELIST statement. */
-
-match
-gfc_match_namelist (void)
-{
- gfc_symbol *group_name, *sym;
- gfc_namelist *nl;
- match m, m2;
-
- m = gfc_match (" / %s /", &group_name);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto error;
-
- for (;;)
- {
- if (group_name->ts.type != BT_UNKNOWN)
- {
- gfc_error ("Namelist group name %qs at %C already has a basic "
- "type of %s", group_name->name,
- gfc_typename (&group_name->ts));
- return MATCH_ERROR;
- }
-
- if (group_name->attr.flavor == FL_NAMELIST
- && group_name->attr.use_assoc
- && !gfc_notify_std (GFC_STD_GNU, "Namelist group name %qs "
- "at %C already is USE associated and can"
- "not be respecified.", group_name->name))
- return MATCH_ERROR;
-
- if (group_name->attr.flavor != FL_NAMELIST
- && !gfc_add_flavor (&group_name->attr, FL_NAMELIST,
- group_name->name, NULL))
- return MATCH_ERROR;
-
- for (;;)
- {
- m = gfc_match_symbol (&sym, 1);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto error;
-
- if (sym->ts.type == BT_UNKNOWN)
- {
- if (gfc_current_ns->seen_implicit_none)
- {
- /* It is required that members of a namelist be declared
- before the namelist. We check this by checking if the
- symbol has a defined type for IMPLICIT NONE. */
- gfc_error ("Symbol %qs in namelist %qs at %C must be "
- "declared before the namelist is declared.",
- sym->name, group_name->name);
- gfc_error_check ();
- }
- else
- /* If the type is not set already, we set it here to the
- implicit default type. It is not allowed to set it
- later to any other type. */
- gfc_set_default_type (sym, 0, gfc_current_ns);
- }
- if (sym->attr.in_namelist == 0
- && !gfc_add_in_namelist (&sym->attr, sym->name, NULL))
- goto error;
-
- /* Use gfc_error_check here, rather than goto error, so that
- these are the only errors for the next two lines. */
- if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
- {
- gfc_error ("Assumed size array %qs in namelist %qs at "
- "%C is not allowed", sym->name, group_name->name);
- gfc_error_check ();
- }
-
- nl = gfc_get_namelist ();
- nl->sym = sym;
- sym->refs++;
-
- if (group_name->namelist == NULL)
- group_name->namelist = group_name->namelist_tail = nl;
- else
- {
- group_name->namelist_tail->next = nl;
- group_name->namelist_tail = nl;
- }
-
- if (gfc_match_eos () == MATCH_YES)
- goto done;
-
- m = gfc_match_char (',');
-
- if (gfc_match_char ('/') == MATCH_YES)
- {
- m2 = gfc_match (" %s /", &group_name);
- if (m2 == MATCH_YES)
- break;
- if (m2 == MATCH_ERROR)
- goto error;
- goto syntax;
- }
-
- if (m != MATCH_YES)
- goto syntax;
- }
- }
-
-done:
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_NAMELIST);
-
-error:
- return MATCH_ERROR;
-}
-
-
-/* Match a MODULE statement. */
-
-match
-gfc_match_module (void)
-{
- match m;
-
- m = gfc_match (" %s%t", &gfc_new_block);
- if (m != MATCH_YES)
- return m;
-
- if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
- gfc_new_block->name, NULL))
- return MATCH_ERROR;
-
- return MATCH_YES;
-}
-
-
-/* Free equivalence sets and lists. Recursively is the easiest way to
- do this. */
-
-void
-gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop)
-{
- if (eq == stop)
- return;
-
- gfc_free_equiv (eq->eq);
- gfc_free_equiv_until (eq->next, stop);
- gfc_free_expr (eq->expr);
- free (eq);
-}
-
-
-void
-gfc_free_equiv (gfc_equiv *eq)
-{
- gfc_free_equiv_until (eq, NULL);
-}
-
-
-/* Match an EQUIVALENCE statement. */
-
-match
-gfc_match_equivalence (void)
-{
- gfc_equiv *eq, *set, *tail;
- gfc_ref *ref;
- gfc_symbol *sym;
- match m;
- gfc_common_head *common_head = NULL;
- bool common_flag;
- int cnt;
- char c;
-
- /* EQUIVALENCE has been matched. After gobbling any possible whitespace,
- the next character needs to be '('. Check that here, and return
- MATCH_NO for a variable of the form equivalencej. */
- gfc_gobble_whitespace ();
- c = gfc_peek_ascii_char ();
- if (c != '(')
- return MATCH_NO;
-
- tail = NULL;
-
- for (;;)
- {
- eq = gfc_get_equiv ();
- if (tail == NULL)
- tail = eq;
-
- eq->next = gfc_current_ns->equiv;
- gfc_current_ns->equiv = eq;
-
- if (gfc_match_char ('(') != MATCH_YES)
- goto syntax;
-
- set = eq;
- common_flag = FALSE;
- cnt = 0;
-
- for (;;)
- {
- m = gfc_match_equiv_variable (&set->expr);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_NO)
- goto syntax;
-
- /* count the number of objects. */
- cnt++;
-
- if (gfc_match_char ('%') == MATCH_YES)
- {
- gfc_error ("Derived type component %C is not a "
- "permitted EQUIVALENCE member");
- goto cleanup;
- }
-
- for (ref = set->expr->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
- {
- gfc_error ("Array reference in EQUIVALENCE at %C cannot "
- "be an array section");
- goto cleanup;
- }
-
- sym = set->expr->symtree->n.sym;
-
- if (!gfc_add_in_equivalence (&sym->attr, sym->name, NULL))
- goto cleanup;
- if (sym->ts.type == BT_CLASS
- && CLASS_DATA (sym)
- && !gfc_add_in_equivalence (&CLASS_DATA (sym)->attr,
- sym->name, NULL))
- goto cleanup;
-
- if (sym->attr.in_common)
- {
- common_flag = TRUE;
- common_head = sym->common_head;
- }
-
- if (gfc_match_char (')') == MATCH_YES)
- break;
-
- if (gfc_match_char (',') != MATCH_YES)
- goto syntax;
-
- set->eq = gfc_get_equiv ();
- set = set->eq;
- }
-
- if (cnt < 2)
- {
- gfc_error ("EQUIVALENCE at %C requires two or more objects");
- goto cleanup;
- }
-
- /* If one of the members of an equivalence is in common, then
- mark them all as being in common. Before doing this, check
- that members of the equivalence group are not in different
- common blocks. */
- if (common_flag)
- for (set = eq; set; set = set->eq)
- {
- sym = set->expr->symtree->n.sym;
- if (sym->common_head && sym->common_head != common_head)
- {
- gfc_error ("Attempt to indirectly overlap COMMON "
- "blocks %s and %s by EQUIVALENCE at %C",
- sym->common_head->name, common_head->name);
- goto cleanup;
- }
- sym->attr.in_common = 1;
- sym->common_head = common_head;
- }
-
- if (gfc_match_eos () == MATCH_YES)
- break;
- if (gfc_match_char (',') != MATCH_YES)
- {
- gfc_error ("Expecting a comma in EQUIVALENCE at %C");
- goto cleanup;
- }
- }
-
- if (!gfc_notify_std (GFC_STD_F2018_OBS, "EQUIVALENCE statement at %C"))
- return MATCH_ERROR;
-
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_EQUIVALENCE);
-
-cleanup:
- eq = tail->next;
- tail->next = NULL;
-
- gfc_free_equiv (gfc_current_ns->equiv);
- gfc_current_ns->equiv = eq;
-
- return MATCH_ERROR;
-}
-
-
-/* Check that a statement function is not recursive. This is done by looking
- for the statement function symbol(sym) by looking recursively through its
- expression(e). If a reference to sym is found, true is returned.
- 12.5.4 requires that any variable of function that is implicitly typed
- shall have that type confirmed by any subsequent type declaration. The
- implicit typing is conveniently done here. */
-static bool
-recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
-
-static bool
-check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
-{
-
- if (e == NULL)
- return false;
-
- switch (e->expr_type)
- {
- case EXPR_FUNCTION:
- if (e->symtree == NULL)
- return false;
-
- /* Check the name before testing for nested recursion! */
- if (sym->name == e->symtree->n.sym->name)
- return true;
-
- /* Catch recursion via other statement functions. */
- if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
- && e->symtree->n.sym->value
- && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
- return true;
-
- if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
- gfc_set_default_type (e->symtree->n.sym, 0, NULL);
-
- break;
-
- case EXPR_VARIABLE:
- if (e->symtree && sym->name == e->symtree->n.sym->name)
- return true;
-
- if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
- gfc_set_default_type (e->symtree->n.sym, 0, NULL);
- break;
-
- default:
- break;
- }
-
- return false;
-}
-
-
-static bool
-recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
-{
- return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
-}
-
-
-/* Match a statement function declaration. It is so easy to match
- non-statement function statements with a MATCH_ERROR as opposed to
- MATCH_NO that we suppress error message in most cases. */
-
-match
-gfc_match_st_function (void)
-{
- gfc_error_buffer old_error;
- gfc_symbol *sym;
- gfc_expr *expr;
- match m;
- char name[GFC_MAX_SYMBOL_LEN + 1];
- locus old_locus;
- bool fcn;
- gfc_formal_arglist *ptr;
-
- /* Read the possible statement function name, and then check to see if
- a symbol is already present in the namespace. Record if it is a
- function and whether it has been referenced. */
- fcn = false;
- ptr = NULL;
- old_locus = gfc_current_locus;
- m = gfc_match_name (name);
- if (m == MATCH_YES)
- {
- gfc_find_symbol (name, NULL, 1, &sym);
- if (sym && sym->attr.function && !sym->attr.referenced)
- {
- fcn = true;
- ptr = sym->formal;
- }
- }
-
- gfc_current_locus = old_locus;
- m = gfc_match_symbol (&sym, 0);
- if (m != MATCH_YES)
- return m;
-
- gfc_push_error (&old_error);
-
- if (!gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, sym->name, NULL))
- goto undo_error;
-
- if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
- goto undo_error;
-
- m = gfc_match (" = %e%t", &expr);
- if (m == MATCH_NO)
- goto undo_error;
-
- gfc_free_error (&old_error);
-
- if (m == MATCH_ERROR)
- return m;
-
- if (recursive_stmt_fcn (expr, sym))
- {
- gfc_error ("Statement function at %L is recursive", &expr->where);
- return MATCH_ERROR;
- }
-
- if (fcn && ptr != sym->formal)
- {
- gfc_error ("Statement function %qs at %L conflicts with function name",
- sym->name, &expr->where);
- return MATCH_ERROR;
- }
-
- sym->value = expr;
-
- if ((gfc_current_state () == COMP_FUNCTION
- || gfc_current_state () == COMP_SUBROUTINE)
- && gfc_state_stack->previous->state == COMP_INTERFACE)
- {
- gfc_error ("Statement function at %L cannot appear within an INTERFACE",
- &expr->where);
- return MATCH_ERROR;
- }
-
- if (!gfc_notify_std (GFC_STD_F95_OBS, "Statement function at %C"))
- return MATCH_ERROR;
-
- return MATCH_YES;
-
-undo_error:
- gfc_pop_error (&old_error);
- return MATCH_NO;
-}
-
-
-/* Match an assignment to a pointer function (F2008). This could, in
- general be ambiguous with a statement function. In this implementation
- it remains so if it is the first statement after the specification
- block. */
-
-match
-gfc_match_ptr_fcn_assign (void)
-{
- gfc_error_buffer old_error;
- locus old_loc;
- gfc_symbol *sym;
- gfc_expr *expr;
- match m;
- char name[GFC_MAX_SYMBOL_LEN + 1];
-
- old_loc = gfc_current_locus;
- m = gfc_match_name (name);
- if (m != MATCH_YES)
- return m;
-
- gfc_find_symbol (name, NULL, 1, &sym);
- if (sym && sym->attr.flavor != FL_PROCEDURE)
- return MATCH_NO;
-
- gfc_push_error (&old_error);
-
- if (sym && sym->attr.function)
- goto match_actual_arglist;
-
- gfc_current_locus = old_loc;
- m = gfc_match_symbol (&sym, 0);
- if (m != MATCH_YES)
- return m;
-
- if (!gfc_add_procedure (&sym->attr, PROC_UNKNOWN, sym->name, NULL))
- goto undo_error;
-
-match_actual_arglist:
- gfc_current_locus = old_loc;
- m = gfc_match (" %e", &expr);
- if (m != MATCH_YES)
- goto undo_error;
-
- new_st.op = EXEC_ASSIGN;
- new_st.expr1 = expr;
- expr = NULL;
-
- m = gfc_match (" = %e%t", &expr);
- if (m != MATCH_YES)
- goto undo_error;
-
- new_st.expr2 = expr;
- return MATCH_YES;
-
-undo_error:
- gfc_pop_error (&old_error);
- return MATCH_NO;
-}
-
-
-/***************** SELECT CASE subroutines ******************/
-
-/* Free a single case structure. */
-
-static void
-free_case (gfc_case *p)
-{
- if (p->low == p->high)
- p->high = NULL;
- gfc_free_expr (p->low);
- gfc_free_expr (p->high);
- free (p);
-}
-
-
-/* Free a list of case structures. */
-
-void
-gfc_free_case_list (gfc_case *p)
-{
- gfc_case *q;
-
- for (; p; p = q)
- {
- q = p->next;
- free_case (p);
- }
-}
-
-
-/* Match a single case selector. Combining the requirements of F08:C830
- and F08:C832 (R838) means that the case-value must have either CHARACTER,
- INTEGER, or LOGICAL type. */
-
-static match
-match_case_selector (gfc_case **cp)
-{
- gfc_case *c;
- match m;
-
- c = gfc_get_case ();
- c->where = gfc_current_locus;
-
- if (gfc_match_char (':') == MATCH_YES)
- {
- m = gfc_match_init_expr (&c->high);
- if (m == MATCH_NO)
- goto need_expr;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- if (c->high->ts.type != BT_LOGICAL && c->high->ts.type != BT_INTEGER
- && c->high->ts.type != BT_CHARACTER)
- {
- gfc_error ("Expression in CASE selector at %L cannot be %s",
- &c->high->where, gfc_typename (&c->high->ts));
- goto cleanup;
- }
- }
- else
- {
- m = gfc_match_init_expr (&c->low);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_NO)
- goto need_expr;
-
- if (c->low->ts.type != BT_LOGICAL && c->low->ts.type != BT_INTEGER
- && c->low->ts.type != BT_CHARACTER)
- {
- gfc_error ("Expression in CASE selector at %L cannot be %s",
- &c->low->where, gfc_typename (&c->low->ts));
- goto cleanup;
- }
-
- /* If we're not looking at a ':' now, make a range out of a single
- target. Else get the upper bound for the case range. */
- if (gfc_match_char (':') != MATCH_YES)
- c->high = c->low;
- else
- {
- m = gfc_match_init_expr (&c->high);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_YES
- && c->high->ts.type != BT_LOGICAL
- && c->high->ts.type != BT_INTEGER
- && c->high->ts.type != BT_CHARACTER)
- {
- gfc_error ("Expression in CASE selector at %L cannot be %s",
- &c->high->where, gfc_typename (c->high));
- goto cleanup;
- }
- /* MATCH_NO is fine. It's OK if nothing is there! */
- }
- }
-
- if (c->low && c->low->rank != 0)
- {
- gfc_error ("Expression in CASE selector at %L must be scalar",
- &c->low->where);
- goto cleanup;
- }
- if (c->high && c->high->rank != 0)
- {
- gfc_error ("Expression in CASE selector at %L must be scalar",
- &c->high->where);
- goto cleanup;
- }
-
- *cp = c;
- return MATCH_YES;
-
-need_expr:
- gfc_error ("Expected initialization expression in CASE at %C");
-
-cleanup:
- free_case (c);
- return MATCH_ERROR;
-}
-
-
-/* Match the end of a case statement. */
-
-static match
-match_case_eos (void)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- match m;
-
- if (gfc_match_eos () == MATCH_YES)
- return MATCH_YES;
-
- /* If the case construct doesn't have a case-construct-name, we
- should have matched the EOS. */
- if (!gfc_current_block ())
- return MATCH_NO;
-
- gfc_gobble_whitespace ();
-
- m = gfc_match_name (name);
- if (m != MATCH_YES)
- return m;
-
- if (strcmp (name, gfc_current_block ()->name) != 0)
- {
- gfc_error ("Expected block name %qs of SELECT construct at %C",
- gfc_current_block ()->name);
- return MATCH_ERROR;
- }
-
- return gfc_match_eos ();
-}
-
-
-/* Match a SELECT statement. */
-
-match
-gfc_match_select (void)
-{
- gfc_expr *expr;
- match m;
-
- m = gfc_match_label ();
- if (m == MATCH_ERROR)
- return m;
-
- m = gfc_match (" select case ( %e )%t", &expr);
- if (m != MATCH_YES)
- return m;
-
- new_st.op = EXEC_SELECT;
- new_st.expr1 = expr;
-
- return MATCH_YES;
-}
-
-
-/* Transfer the selector typespec to the associate name. */
-
-static void
-copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
-{
- gfc_ref *ref;
- gfc_symbol *assoc_sym;
- int rank = 0;
-
- assoc_sym = associate->symtree->n.sym;
-
- /* At this stage the expression rank and arrayspec dimensions have
- not been completely sorted out. We must get the expr2->rank
- right here, so that the correct class container is obtained. */
- ref = selector->ref;
- while (ref && ref->next)
- ref = ref->next;
-
- if (selector->ts.type == BT_CLASS
- && CLASS_DATA (selector)
- && CLASS_DATA (selector)->as
- && CLASS_DATA (selector)->as->type == AS_ASSUMED_RANK)
- {
- assoc_sym->attr.dimension = 1;
- assoc_sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as);
- goto build_class_sym;
- }
- else if (selector->ts.type == BT_CLASS
- && CLASS_DATA (selector)
- && CLASS_DATA (selector)->as
- && ref && ref->type == REF_ARRAY)
- {
- /* Ensure that the array reference type is set. We cannot use
- gfc_resolve_expr at this point, so the usable parts of
- resolve.c(resolve_array_ref) are employed to do it. */
- if (ref->u.ar.type == AR_UNKNOWN)
- {
- ref->u.ar.type = AR_ELEMENT;
- for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
- if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
- || ref->u.ar.dimen_type[i] == DIMEN_VECTOR
- || (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
- && ref->u.ar.start[i] && ref->u.ar.start[i]->rank))
- {
- ref->u.ar.type = AR_SECTION;
- break;
- }
- }
-
- if (ref->u.ar.type == AR_FULL)
- selector->rank = CLASS_DATA (selector)->as->rank;
- else if (ref->u.ar.type == AR_SECTION)
- selector->rank = ref->u.ar.dimen;
- else
- selector->rank = 0;
-
- rank = selector->rank;
- }
-
- if (rank)
- {
- for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
- if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT
- || (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
- && ref->u.ar.end[i] == NULL
- && ref->u.ar.stride[i] == NULL))
- rank--;
-
- if (rank)
- {
- assoc_sym->attr.dimension = 1;
- assoc_sym->as = gfc_get_array_spec ();
- assoc_sym->as->rank = rank;
- assoc_sym->as->type = AS_DEFERRED;
- }
- else
- assoc_sym->as = NULL;
- }
- else
- assoc_sym->as = NULL;
-
-build_class_sym:
- if (selector->ts.type == BT_CLASS)
- {
- /* The correct class container has to be available. */
- assoc_sym->ts.type = BT_CLASS;
- assoc_sym->ts.u.derived = CLASS_DATA (selector)
- ? CLASS_DATA (selector)->ts.u.derived : selector->ts.u.derived;
- assoc_sym->attr.pointer = 1;
- gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as);
- }
-}
-
-
-/* Push the current selector onto the SELECT TYPE stack. */
-
-static void
-select_type_push (gfc_symbol *sel)
-{
- gfc_select_type_stack *top = gfc_get_select_type_stack ();
- top->selector = sel;
- top->tmp = NULL;
- top->prev = select_type_stack;
-
- select_type_stack = top;
-}
-
-
-/* Set the temporary for the current intrinsic SELECT TYPE selector. */
-
-static gfc_symtree *
-select_intrinsic_set_tmp (gfc_typespec *ts)
-{
- char name[GFC_MAX_SYMBOL_LEN];
- gfc_symtree *tmp;
- HOST_WIDE_INT charlen = 0;
- gfc_symbol *selector = select_type_stack->selector;
- gfc_symbol *sym;
-
- if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
- return NULL;
-
- if (selector->ts.type == BT_CLASS && !selector->attr.class_ok)
- return NULL;
-
- /* Case value == NULL corresponds to SELECT TYPE cases otherwise
- the values correspond to SELECT rank cases. */
- if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
- && ts->u.cl->length->expr_type == EXPR_CONSTANT)
- charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
-
- if (ts->type != BT_CHARACTER)
- sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type),
- ts->kind);
- else
- snprintf (name, sizeof (name),
- "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
- gfc_basic_typename (ts->type), charlen, ts->kind);
-
- gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
- sym = tmp->n.sym;
- gfc_add_type (sym, ts, NULL);
-
- /* Copy across the array spec to the selector. */
- if (selector->ts.type == BT_CLASS
- && (CLASS_DATA (selector)->attr.dimension
- || CLASS_DATA (selector)->attr.codimension))
- {
- sym->attr.pointer = 1;
- sym->attr.dimension = CLASS_DATA (selector)->attr.dimension;
- sym->attr.codimension = CLASS_DATA (selector)->attr.codimension;
- sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as);
- }
-
- gfc_set_sym_referenced (sym);
- gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL);
- sym->attr.select_type_temporary = 1;
-
- return tmp;
-}
-
-
-/* Set up a temporary for the current TYPE IS / CLASS IS branch . */
-
-static void
-select_type_set_tmp (gfc_typespec *ts)
-{
- char name[GFC_MAX_SYMBOL_LEN + 12 + 1];
- gfc_symtree *tmp = NULL;
- gfc_symbol *selector = select_type_stack->selector;
- gfc_symbol *sym;
-
- if (!ts)
- {
- select_type_stack->tmp = NULL;
- return;
- }
-
- tmp = select_intrinsic_set_tmp (ts);
-
- if (tmp == NULL)
- {
- if (!ts->u.derived)
- return;
-
- if (ts->type == BT_CLASS)
- sprintf (name, "__tmp_class_%s", ts->u.derived->name);
- else
- sprintf (name, "__tmp_type_%s", ts->u.derived->name);
-
- gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
- sym = tmp->n.sym;
- gfc_add_type (sym, ts, NULL);
-
- if (selector->ts.type == BT_CLASS && selector->attr.class_ok
- && selector->ts.u.derived && CLASS_DATA (selector))
- {
- sym->attr.pointer
- = CLASS_DATA (selector)->attr.class_pointer;
-
- /* Copy across the array spec to the selector. */
- if (CLASS_DATA (selector)->attr.dimension
- || CLASS_DATA (selector)->attr.codimension)
- {
- sym->attr.dimension
- = CLASS_DATA (selector)->attr.dimension;
- sym->attr.codimension
- = CLASS_DATA (selector)->attr.codimension;
- if (CLASS_DATA (selector)->as->type != AS_EXPLICIT)
- sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as);
- else
- {
- sym->as = gfc_get_array_spec();
- sym->as->rank = CLASS_DATA (selector)->as->rank;
- sym->as->type = AS_DEFERRED;
- }
- }
- }
-
- gfc_set_sym_referenced (sym);
- gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL);
- sym->attr.select_type_temporary = 1;
-
- if (ts->type == BT_CLASS)
- gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
- }
- else
- sym = tmp->n.sym;
-
-
- /* Add an association for it, so the rest of the parser knows it is
- an associate-name. The target will be set during resolution. */
- sym->assoc = gfc_get_association_list ();
- sym->assoc->dangling = 1;
- sym->assoc->st = tmp;
-
- select_type_stack->tmp = tmp;
-}
-
-
-/* Match a SELECT TYPE statement. */
-
-match
-gfc_match_select_type (void)
-{
- gfc_expr *expr1, *expr2 = NULL;
- match m;
- char name[GFC_MAX_SYMBOL_LEN + 1];
- bool class_array;
- gfc_symbol *sym;
- gfc_namespace *ns = gfc_current_ns;
-
- m = gfc_match_label ();
- if (m == MATCH_ERROR)
- return m;
-
- m = gfc_match (" select type ( ");
- if (m != MATCH_YES)
- return m;
-
- if (gfc_current_state() == COMP_MODULE
- || gfc_current_state() == COMP_SUBMODULE)
- {
- gfc_error ("SELECT TYPE at %C cannot appear in this scope");
- return MATCH_ERROR;
- }
-
- gfc_current_ns = gfc_build_block_ns (ns);
- m = gfc_match (" %n => %e", name, &expr2);
- if (m == MATCH_YES)
- {
- expr1 = gfc_get_expr ();
- expr1->expr_type = EXPR_VARIABLE;
- expr1->where = expr2->where;
- if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
- {
- m = MATCH_ERROR;
- goto cleanup;
- }
-
- sym = expr1->symtree->n.sym;
- if (expr2->ts.type == BT_UNKNOWN)
- sym->attr.untyped = 1;
- else
- copy_ts_from_selector_to_associate (expr1, expr2);
-
- sym->attr.flavor = FL_VARIABLE;
- sym->attr.referenced = 1;
- sym->attr.class_ok = 1;
- }
- else
- {
- m = gfc_match (" %e ", &expr1);
- if (m != MATCH_YES)
- {
- std::swap (ns, gfc_current_ns);
- gfc_free_namespace (ns);
- return m;
- }
- }
-
- m = gfc_match (" )%t");
- if (m != MATCH_YES)
- {
- gfc_error ("parse error in SELECT TYPE statement at %C");
- goto cleanup;
- }
-
- /* This ghastly expression seems to be needed to distinguish a CLASS
- array, which can have a reference, from other expressions that
- have references, such as derived type components, and are not
- allowed by the standard.
- TODO: see if it is sufficient to exclude component and substring
- references. */
- class_array = (expr1->expr_type == EXPR_VARIABLE
- && expr1->ts.type == BT_CLASS
- && CLASS_DATA (expr1)
- && (strcmp (CLASS_DATA (expr1)->name, "_data") == 0)
- && (CLASS_DATA (expr1)->attr.dimension
- || CLASS_DATA (expr1)->attr.codimension)
- && expr1->ref
- && expr1->ref->type == REF_ARRAY
- && expr1->ref->u.ar.type == AR_FULL
- && expr1->ref->next == NULL);
-
- /* Check for F03:C811 (F08:C835). */
- if (!expr2 && (expr1->expr_type != EXPR_VARIABLE
- || (!class_array && expr1->ref != NULL)))
- {
- gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
- "use associate-name=>");
- m = MATCH_ERROR;
- goto cleanup;
- }
-
- new_st.op = EXEC_SELECT_TYPE;
- new_st.expr1 = expr1;
- new_st.expr2 = expr2;
- new_st.ext.block.ns = gfc_current_ns;
-
- select_type_push (expr1->symtree->n.sym);
- gfc_current_ns = ns;
-
- return MATCH_YES;
-
-cleanup:
- gfc_free_expr (expr1);
- gfc_free_expr (expr2);
- gfc_undo_symbols ();
- std::swap (ns, gfc_current_ns);
- gfc_free_namespace (ns);
- return m;
-}
-
-
-/* Set the temporary for the current intrinsic SELECT RANK selector. */
-
-static void
-select_rank_set_tmp (gfc_typespec *ts, int *case_value)
-{
- char name[2 * GFC_MAX_SYMBOL_LEN];
- char tname[GFC_MAX_SYMBOL_LEN + 7];
- gfc_symtree *tmp;
- gfc_symbol *selector = select_type_stack->selector;
- gfc_symbol *sym;
- gfc_symtree *st;
- HOST_WIDE_INT charlen = 0;
-
- if (case_value == NULL)
- return;
-
- if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
- && ts->u.cl->length->expr_type == EXPR_CONSTANT)
- charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
-
- if (ts->type == BT_CLASS)
- sprintf (tname, "class_%s", ts->u.derived->name);
- else if (ts->type == BT_DERIVED)
- sprintf (tname, "type_%s", ts->u.derived->name);
- else if (ts->type != BT_CHARACTER)
- sprintf (tname, "%s_%d", gfc_basic_typename (ts->type), ts->kind);
- else
- sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
- gfc_basic_typename (ts->type), charlen, ts->kind);
-
- /* Case value == NULL corresponds to SELECT TYPE cases otherwise
- the values correspond to SELECT rank cases. */
- if (*case_value >=0)
- sprintf (name, "__tmp_%s_rank_%d", tname, *case_value);
- else
- sprintf (name, "__tmp_%s_rank_m%d", tname, -*case_value);
-
- gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
- if (st)
- return;
-
- gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
- sym = tmp->n.sym;
- gfc_add_type (sym, ts, NULL);
-
- /* Copy across the array spec to the selector. */
- if (selector->ts.type == BT_CLASS)
- {
- sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived;
- sym->attr.pointer = CLASS_DATA (selector)->attr.pointer;
- sym->attr.allocatable = CLASS_DATA (selector)->attr.allocatable;
- sym->attr.target = CLASS_DATA (selector)->attr.target;
- sym->attr.class_ok = 0;
- if (case_value && *case_value != 0)
- {
- sym->attr.dimension = 1;
- sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as);
- if (*case_value > 0)
- {
- sym->as->type = AS_DEFERRED;
- sym->as->rank = *case_value;
- }
- else if (*case_value == -1)
- {
- sym->as->type = AS_ASSUMED_SIZE;
- sym->as->rank = 1;
- }
- }
- }
- else
- {
- sym->attr.pointer = selector->attr.pointer;
- sym->attr.allocatable = selector->attr.allocatable;
- sym->attr.target = selector->attr.target;
- if (case_value && *case_value != 0)
- {
- sym->attr.dimension = 1;
- sym->as = gfc_copy_array_spec (selector->as);
- if (*case_value > 0)
- {
- sym->as->type = AS_DEFERRED;
- sym->as->rank = *case_value;
- }
- else if (*case_value == -1)
- {
- sym->as->type = AS_ASSUMED_SIZE;
- sym->as->rank = 1;
- }
- }
- }
-
- gfc_set_sym_referenced (sym);
- gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL);
- sym->attr.select_type_temporary = 1;
- if (case_value)
- sym->attr.select_rank_temporary = 1;
-
- if (ts->type == BT_CLASS)
- gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
-
- /* Add an association for it, so the rest of the parser knows it is
- an associate-name. The target will be set during resolution. */
- sym->assoc = gfc_get_association_list ();
- sym->assoc->dangling = 1;
- sym->assoc->st = tmp;
-
- select_type_stack->tmp = tmp;
-}
-
-
-/* Match a SELECT RANK statement. */
-
-match
-gfc_match_select_rank (void)
-{
- gfc_expr *expr1, *expr2 = NULL;
- match m;
- char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_symbol *sym, *sym2;
- gfc_namespace *ns = gfc_current_ns;
- gfc_array_spec *as = NULL;
-
- m = gfc_match_label ();
- if (m == MATCH_ERROR)
- return m;
-
- m = gfc_match (" select rank ( ");
- if (m != MATCH_YES)
- return m;
-
- if (!gfc_notify_std (GFC_STD_F2018, "SELECT RANK statement at %C"))
- return MATCH_NO;
-
- gfc_current_ns = gfc_build_block_ns (ns);
- m = gfc_match (" %n => %e", name, &expr2);
- if (m == MATCH_YES)
- {
- expr1 = gfc_get_expr ();
- expr1->expr_type = EXPR_VARIABLE;
- expr1->where = expr2->where;
- expr1->ref = gfc_copy_ref (expr2->ref);
- if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
- {
- m = MATCH_ERROR;
- goto cleanup;
- }
-
- sym = expr1->symtree->n.sym;
-
- if (expr2->symtree)
- {
- sym2 = expr2->symtree->n.sym;
- as = (sym2->ts.type == BT_CLASS
- && CLASS_DATA (sym2)) ? CLASS_DATA (sym2)->as : sym2->as;
- }
-
- if (expr2->expr_type != EXPR_VARIABLE
- || !(as && as->type == AS_ASSUMED_RANK))
- {
- gfc_error ("The SELECT RANK selector at %C must be an assumed "
- "rank variable");
- m = MATCH_ERROR;
- goto cleanup;
- }
-
- if (expr2->ts.type == BT_CLASS && CLASS_DATA (sym2))
- {
- copy_ts_from_selector_to_associate (expr1, expr2);
-
- sym->attr.flavor = FL_VARIABLE;
- sym->attr.referenced = 1;
- sym->attr.class_ok = 1;
- CLASS_DATA (sym)->attr.allocatable = CLASS_DATA (sym2)->attr.allocatable;
- CLASS_DATA (sym)->attr.pointer = CLASS_DATA (sym2)->attr.pointer;
- CLASS_DATA (sym)->attr.target = CLASS_DATA (sym2)->attr.target;
- sym->attr.pointer = 1;
- }
- else
- {
- sym->ts = sym2->ts;
- sym->as = gfc_copy_array_spec (sym2->as);
- sym->attr.dimension = 1;
-
- sym->attr.flavor = FL_VARIABLE;
- sym->attr.referenced = 1;
- sym->attr.class_ok = sym2->attr.class_ok;
- sym->attr.allocatable = sym2->attr.allocatable;
- sym->attr.pointer = sym2->attr.pointer;
- sym->attr.target = sym2->attr.target;
- }
- }
- else
- {
- m = gfc_match (" %e ", &expr1);
-
- if (m != MATCH_YES)
- {
- gfc_undo_symbols ();
- std::swap (ns, gfc_current_ns);
- gfc_free_namespace (ns);
- return m;
- }
-
- if (expr1->symtree)
- {
- sym = expr1->symtree->n.sym;
- as = (sym->ts.type == BT_CLASS
- && CLASS_DATA (sym)) ? CLASS_DATA (sym)->as : sym->as;
- }
-
- if (expr1->expr_type != EXPR_VARIABLE
- || !(as && as->type == AS_ASSUMED_RANK))
- {
- gfc_error("The SELECT RANK selector at %C must be an assumed "
- "rank variable");
- m = MATCH_ERROR;
- goto cleanup;
- }
- }
-
- m = gfc_match (" )%t");
- if (m != MATCH_YES)
- {
- gfc_error ("parse error in SELECT RANK statement at %C");
- goto cleanup;
- }
-
- new_st.op = EXEC_SELECT_RANK;
- new_st.expr1 = expr1;
- new_st.expr2 = expr2;
- new_st.ext.block.ns = gfc_current_ns;
-
- select_type_push (expr1->symtree->n.sym);
- gfc_current_ns = ns;
-
- return MATCH_YES;
-
-cleanup:
- gfc_free_expr (expr1);
- gfc_free_expr (expr2);
- gfc_undo_symbols ();
- std::swap (ns, gfc_current_ns);
- gfc_free_namespace (ns);
- return m;
-}
-
-
-/* Match a CASE statement. */
-
-match
-gfc_match_case (void)
-{
- gfc_case *c, *head, *tail;
- match m;
-
- head = tail = NULL;
-
- if (gfc_current_state () != COMP_SELECT)
- {
- gfc_error ("Unexpected CASE statement at %C");
- return MATCH_ERROR;
- }
-
- if (gfc_match ("% default") == MATCH_YES)
- {
- m = match_case_eos ();
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- new_st.op = EXEC_SELECT;
- c = gfc_get_case ();
- c->where = gfc_current_locus;
- new_st.ext.block.case_list = c;
- return MATCH_YES;
- }
-
- if (gfc_match_char ('(') != MATCH_YES)
- goto syntax;
-
- for (;;)
- {
- if (match_case_selector (&c) == MATCH_ERROR)
- goto cleanup;
-
- if (head == NULL)
- head = c;
- else
- tail->next = c;
-
- tail = c;
-
- if (gfc_match_char (')') == MATCH_YES)
- break;
- if (gfc_match_char (',') != MATCH_YES)
- goto syntax;
- }
-
- m = match_case_eos ();
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- new_st.op = EXEC_SELECT;
- new_st.ext.block.case_list = head;
-
- return MATCH_YES;
-
-syntax:
- gfc_error ("Syntax error in CASE specification at %C");
-
-cleanup:
- gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */
- return MATCH_ERROR;
-}
-
-
-/* Match a TYPE IS statement. */
-
-match
-gfc_match_type_is (void)
-{
- gfc_case *c = NULL;
- match m;
-
- if (gfc_current_state () != COMP_SELECT_TYPE)
- {
- gfc_error ("Unexpected TYPE IS statement at %C");
- return MATCH_ERROR;
- }
-
- if (gfc_match_char ('(') != MATCH_YES)
- goto syntax;
-
- c = gfc_get_case ();
- c->where = gfc_current_locus;
-
- m = gfc_match_type_spec (&c->ts);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- if (gfc_match_char (')') != MATCH_YES)
- goto syntax;
-
- m = match_case_eos ();
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- new_st.op = EXEC_SELECT_TYPE;
- new_st.ext.block.case_list = c;
-
- if (c->ts.type == BT_DERIVED && c->ts.u.derived
- && (c->ts.u.derived->attr.sequence
- || c->ts.u.derived->attr.is_bind_c))
- {
- gfc_error ("The type-spec shall not specify a sequence derived "
- "type or a type with the BIND attribute in SELECT "
- "TYPE at %C [F2003:C815]");
- return MATCH_ERROR;
- }
-
- if (c->ts.type == BT_DERIVED
- && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
- && gfc_spec_list_type (type_param_spec_list, c->ts.u.derived)
- != SPEC_ASSUMED)
- {
- gfc_error ("All the LEN type parameters in the TYPE IS statement "
- "at %C must be ASSUMED");
- return MATCH_ERROR;
- }
-
- /* Create temporary variable. */
- select_type_set_tmp (&c->ts);
-
- return MATCH_YES;
-
-syntax:
- gfc_error ("Syntax error in TYPE IS specification at %C");
-
-cleanup:
- if (c != NULL)
- gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */
- return MATCH_ERROR;
-}
-
-
-/* Match a CLASS IS or CLASS DEFAULT statement. */
-
-match
-gfc_match_class_is (void)
-{
- gfc_case *c = NULL;
- match m;
-
- if (gfc_current_state () != COMP_SELECT_TYPE)
- return MATCH_NO;
-
- if (gfc_match ("% default") == MATCH_YES)
- {
- m = match_case_eos ();
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- new_st.op = EXEC_SELECT_TYPE;
- c = gfc_get_case ();
- c->where = gfc_current_locus;
- c->ts.type = BT_UNKNOWN;
- new_st.ext.block.case_list = c;
- select_type_set_tmp (NULL);
- return MATCH_YES;
- }
-
- m = gfc_match ("% is");
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- if (gfc_match_char ('(') != MATCH_YES)
- goto syntax;
-
- c = gfc_get_case ();
- c->where = gfc_current_locus;
-
- m = match_derived_type_spec (&c->ts);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- if (c->ts.type == BT_DERIVED)
- c->ts.type = BT_CLASS;
-
- if (gfc_match_char (')') != MATCH_YES)
- goto syntax;
-
- m = match_case_eos ();
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- new_st.op = EXEC_SELECT_TYPE;
- new_st.ext.block.case_list = c;
-
- /* Create temporary variable. */
- select_type_set_tmp (&c->ts);
-
- return MATCH_YES;
-
-syntax:
- gfc_error ("Syntax error in CLASS IS specification at %C");
-
-cleanup:
- if (c != NULL)
- gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */
- return MATCH_ERROR;
-}
-
-
-/* Match a RANK statement. */
-
-match
-gfc_match_rank_is (void)
-{
- gfc_case *c = NULL;
- match m;
- int case_value;
-
- if (gfc_current_state () != COMP_SELECT_RANK)
- {
- gfc_error ("Unexpected RANK statement at %C");
- return MATCH_ERROR;
- }
-
- if (gfc_match ("% default") == MATCH_YES)
- {
- m = match_case_eos ();
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- new_st.op = EXEC_SELECT_RANK;
- c = gfc_get_case ();
- c->ts.type = BT_UNKNOWN;
- c->where = gfc_current_locus;
- new_st.ext.block.case_list = c;
- select_type_stack->tmp = NULL;
- return MATCH_YES;
- }
-
- if (gfc_match_char ('(') != MATCH_YES)
- goto syntax;
-
- c = gfc_get_case ();
- c->where = gfc_current_locus;
- c->ts = select_type_stack->selector->ts;
-
- m = gfc_match_expr (&c->low);
- if (m == MATCH_NO)
- {
- if (gfc_match_char ('*') == MATCH_YES)
- c->low = gfc_get_int_expr (gfc_default_integer_kind,
- NULL, -1);
- else
- goto syntax;
-
- case_value = -1;
- }
- else if (m == MATCH_YES)
- {
- /* F2018: R1150 */
- if (c->low->expr_type != EXPR_CONSTANT
- || c->low->ts.type != BT_INTEGER
- || c->low->rank)
- {
- gfc_error ("The SELECT RANK CASE expression at %C must be a "
- "scalar, integer constant");
- goto cleanup;
- }
-
- case_value = (int) mpz_get_si (c->low->value.integer);
- /* F2018: C1151 */
- if ((case_value < 0) || (case_value > GFC_MAX_DIMENSIONS))
- {
- gfc_error ("The value of the SELECT RANK CASE expression at "
- "%C must not be less than zero or greater than %d",
- GFC_MAX_DIMENSIONS);
- goto cleanup;
- }
- }
- else
- goto cleanup;
-
- if (gfc_match_char (')') != MATCH_YES)
- goto syntax;
-
- m = match_case_eos ();
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- new_st.op = EXEC_SELECT_RANK;
- new_st.ext.block.case_list = c;
-
- /* Create temporary variable. Recycle the select type code. */
- select_rank_set_tmp (&c->ts, &case_value);
-
- return MATCH_YES;
-
-syntax:
- gfc_error ("Syntax error in RANK specification at %C");
-
-cleanup:
- if (c != NULL)
- gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */
- return MATCH_ERROR;
-}
-
-/********************* WHERE subroutines ********************/
-
-/* Match the rest of a simple WHERE statement that follows an IF statement.
- */
-
-static match
-match_simple_where (void)
-{
- gfc_expr *expr;
- gfc_code *c;
- match m;
-
- m = gfc_match (" ( %e )", &expr);
- if (m != MATCH_YES)
- return m;
-
- m = gfc_match_assignment ();
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- if (gfc_match_eos () != MATCH_YES)
- goto syntax;
-
- c = gfc_get_code (EXEC_WHERE);
- c->expr1 = expr;
-
- c->next = XCNEW (gfc_code);
- *c->next = new_st;
- c->next->loc = gfc_current_locus;
- gfc_clear_new_st ();
-
- new_st.op = EXEC_WHERE;
- new_st.block = c;
-
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_WHERE);
-
-cleanup:
- gfc_free_expr (expr);
- return MATCH_ERROR;
-}
-
-
-/* Match a WHERE statement. */
-
-match
-gfc_match_where (gfc_statement *st)
-{
- gfc_expr *expr;
- match m0, m;
- gfc_code *c;
-
- m0 = gfc_match_label ();
- if (m0 == MATCH_ERROR)
- return m0;
-
- m = gfc_match (" where ( %e )", &expr);
- if (m != MATCH_YES)
- return m;
-
- if (gfc_match_eos () == MATCH_YES)
- {
- *st = ST_WHERE_BLOCK;
- new_st.op = EXEC_WHERE;
- new_st.expr1 = expr;
- return MATCH_YES;
- }
-
- m = gfc_match_assignment ();
- if (m == MATCH_NO)
- gfc_syntax_error (ST_WHERE);
-
- if (m != MATCH_YES)
- {
- gfc_free_expr (expr);
- return MATCH_ERROR;
- }
-
- /* We've got a simple WHERE statement. */
- *st = ST_WHERE;
- c = gfc_get_code (EXEC_WHERE);
- c->expr1 = expr;
-
- /* Put in the assignment. It will not be processed by add_statement, so we
- need to copy the location here. */
-
- c->next = XCNEW (gfc_code);
- *c->next = new_st;
- c->next->loc = gfc_current_locus;
- gfc_clear_new_st ();
-
- new_st.op = EXEC_WHERE;
- new_st.block = c;
-
- return MATCH_YES;
-}
-
-
-/* Match an ELSEWHERE statement. We leave behind a WHERE node in
- new_st if successful. */
-
-match
-gfc_match_elsewhere (void)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_expr *expr;
- match m;
-
- if (gfc_current_state () != COMP_WHERE)
- {
- gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
- return MATCH_ERROR;
- }
-
- expr = NULL;
-
- if (gfc_match_char ('(') == MATCH_YES)
- {
- m = gfc_match_expr (&expr);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- return MATCH_ERROR;
-
- if (gfc_match_char (')') != MATCH_YES)
- goto syntax;
- }
-
- if (gfc_match_eos () != MATCH_YES)
- {
- /* Only makes sense if we have a where-construct-name. */
- if (!gfc_current_block ())
- {
- m = MATCH_ERROR;
- goto cleanup;
- }
- /* Better be a name at this point. */
- m = gfc_match_name (name);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- if (gfc_match_eos () != MATCH_YES)
- goto syntax;
-
- if (strcmp (name, gfc_current_block ()->name) != 0)
- {
- gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
- name, gfc_current_block ()->name);
- goto cleanup;
- }
- }
-
- new_st.op = EXEC_WHERE;
- new_st.expr1 = expr;
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_ELSEWHERE);
-
-cleanup:
- gfc_free_expr (expr);
- return MATCH_ERROR;
-}
generated by cgit v1.1 at 2025-08-10 21:08:56 +0000