aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/primary.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/primary.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/primary.c')
-rw-r--r--gcc/fortran/primary.c4175
1 files changed, 0 insertions, 4175 deletions
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
deleted file mode 100644
index 3f01f67..0000000
--- a/gcc/fortran/primary.c
+++ /dev/null
@@ -1,4175 +0,0 @@
-/* Primary expression subroutines
- 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 "arith.h"
-#include "match.h"
-#include "parse.h"
-#include "constructor.h"
-
-int matching_actual_arglist = 0;
-
-/* Matches a kind-parameter expression, which is either a named
- symbolic constant or a nonnegative integer constant. If
- successful, sets the kind value to the correct integer.
- The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
- symbol like e.g. 'c_int'. */
-
-static match
-match_kind_param (int *kind, int *is_iso_c)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_symbol *sym;
- match m;
-
- *is_iso_c = 0;
-
- m = gfc_match_small_literal_int (kind, NULL);
- if (m != MATCH_NO)
- return m;
-
- m = gfc_match_name (name);
- if (m != MATCH_YES)
- return m;
-
- if (gfc_find_symbol (name, NULL, 1, &sym))
- return MATCH_ERROR;
-
- if (sym == NULL)
- return MATCH_NO;
-
- *is_iso_c = sym->attr.is_iso_c;
-
- if (sym->attr.flavor != FL_PARAMETER)
- return MATCH_NO;
-
- if (sym->value == NULL)
- return MATCH_NO;
-
- if (gfc_extract_int (sym->value, kind))
- return MATCH_NO;
-
- gfc_set_sym_referenced (sym);
-
- if (*kind < 0)
- return MATCH_NO;
-
- return MATCH_YES;
-}
-
-
-/* Get a trailing kind-specification for non-character variables.
- Returns:
- * the integer kind value or
- * -1 if an error was generated,
- * -2 if no kind was found.
- The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
- symbol like e.g. 'c_int'. */
-
-static int
-get_kind (int *is_iso_c)
-{
- int kind;
- match m;
-
- *is_iso_c = 0;
-
- if (gfc_match_char ('_') != MATCH_YES)
- return -2;
-
- m = match_kind_param (&kind, is_iso_c);
- if (m == MATCH_NO)
- gfc_error ("Missing kind-parameter at %C");
-
- return (m == MATCH_YES) ? kind : -1;
-}
-
-
-/* Given a character and a radix, see if the character is a valid
- digit in that radix. */
-
-int
-gfc_check_digit (char c, int radix)
-{
- int r;
-
- switch (radix)
- {
- case 2:
- r = ('0' <= c && c <= '1');
- break;
-
- case 8:
- r = ('0' <= c && c <= '7');
- break;
-
- case 10:
- r = ('0' <= c && c <= '9');
- break;
-
- case 16:
- r = ISXDIGIT (c);
- break;
-
- default:
- gfc_internal_error ("gfc_check_digit(): bad radix");
- }
-
- return r;
-}
-
-
-/* Match the digit string part of an integer if signflag is not set,
- the signed digit string part if signflag is set. If the buffer
- is NULL, we just count characters for the resolution pass. Returns
- the number of characters matched, -1 for no match. */
-
-static int
-match_digits (int signflag, int radix, char *buffer)
-{
- locus old_loc;
- int length;
- char c;
-
- length = 0;
- c = gfc_next_ascii_char ();
-
- if (signflag && (c == '+' || c == '-'))
- {
- if (buffer != NULL)
- *buffer++ = c;
- gfc_gobble_whitespace ();
- c = gfc_next_ascii_char ();
- length++;
- }
-
- if (!gfc_check_digit (c, radix))
- return -1;
-
- length++;
- if (buffer != NULL)
- *buffer++ = c;
-
- for (;;)
- {
- old_loc = gfc_current_locus;
- c = gfc_next_ascii_char ();
-
- if (!gfc_check_digit (c, radix))
- break;
-
- if (buffer != NULL)
- *buffer++ = c;
- length++;
- }
-
- gfc_current_locus = old_loc;
-
- return length;
-}
-
-/* Convert an integer string to an expression node. */
-
-static gfc_expr *
-convert_integer (const char *buffer, int kind, int radix, locus *where)
-{
- gfc_expr *e;
- const char *t;
-
- e = gfc_get_constant_expr (BT_INTEGER, kind, where);
- /* A leading plus is allowed, but not by mpz_set_str. */
- if (buffer[0] == '+')
- t = buffer + 1;
- else
- t = buffer;
- mpz_set_str (e->value.integer, t, radix);
-
- return e;
-}
-
-
-/* Convert a real string to an expression node. */
-
-static gfc_expr *
-convert_real (const char *buffer, int kind, locus *where)
-{
- gfc_expr *e;
-
- e = gfc_get_constant_expr (BT_REAL, kind, where);
- mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
-
- return e;
-}
-
-
-/* Convert a pair of real, constant expression nodes to a single
- complex expression node. */
-
-static gfc_expr *
-convert_complex (gfc_expr *real, gfc_expr *imag, int kind)
-{
- gfc_expr *e;
-
- e = gfc_get_constant_expr (BT_COMPLEX, kind, &real->where);
- mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real,
- GFC_MPC_RND_MODE);
-
- return e;
-}
-
-
-/* Match an integer (digit string and optional kind).
- A sign will be accepted if signflag is set. */
-
-static match
-match_integer_constant (gfc_expr **result, int signflag)
-{
- int length, kind, is_iso_c;
- locus old_loc;
- char *buffer;
- gfc_expr *e;
-
- old_loc = gfc_current_locus;
- gfc_gobble_whitespace ();
-
- length = match_digits (signflag, 10, NULL);
- gfc_current_locus = old_loc;
- if (length == -1)
- return MATCH_NO;
-
- buffer = (char *) alloca (length + 1);
- memset (buffer, '\0', length + 1);
-
- gfc_gobble_whitespace ();
-
- match_digits (signflag, 10, buffer);
-
- kind = get_kind (&is_iso_c);
- if (kind == -2)
- kind = gfc_default_integer_kind;
- if (kind == -1)
- return MATCH_ERROR;
-
- if (kind == 4 && flag_integer4_kind == 8)
- kind = 8;
-
- if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
- {
- gfc_error ("Integer kind %d at %C not available", kind);
- return MATCH_ERROR;
- }
-
- e = convert_integer (buffer, kind, 10, &gfc_current_locus);
- e->ts.is_c_interop = is_iso_c;
-
- if (gfc_range_check (e) != ARITH_OK)
- {
- gfc_error ("Integer too big for its kind at %C. This check can be "
- "disabled with the option %<-fno-range-check%>");
-
- gfc_free_expr (e);
- return MATCH_ERROR;
- }
-
- *result = e;
- return MATCH_YES;
-}
-
-
-/* Match a Hollerith constant. */
-
-static match
-match_hollerith_constant (gfc_expr **result)
-{
- locus old_loc;
- gfc_expr *e = NULL;
- int num, pad;
- int i;
-
- old_loc = gfc_current_locus;
- gfc_gobble_whitespace ();
-
- if (match_integer_constant (&e, 0) == MATCH_YES
- && gfc_match_char ('h') == MATCH_YES)
- {
- if (!gfc_notify_std (GFC_STD_LEGACY, "Hollerith constant at %C"))
- goto cleanup;
-
- if (gfc_extract_int (e, &num, 1))
- goto cleanup;
- if (num == 0)
- {
- gfc_error ("Invalid Hollerith constant: %L must contain at least "
- "one character", &old_loc);
- goto cleanup;
- }
- if (e->ts.kind != gfc_default_integer_kind)
- {
- gfc_error ("Invalid Hollerith constant: Integer kind at %L "
- "should be default", &old_loc);
- goto cleanup;
- }
- else
- {
- gfc_free_expr (e);
- e = gfc_get_constant_expr (BT_HOLLERITH, gfc_default_character_kind,
- &gfc_current_locus);
-
- /* Calculate padding needed to fit default integer memory. */
- pad = gfc_default_integer_kind - (num % gfc_default_integer_kind);
-
- e->representation.string = XCNEWVEC (char, num + pad + 1);
-
- for (i = 0; i < num; i++)
- {
- gfc_char_t c = gfc_next_char_literal (INSTRING_WARN);
- if (! gfc_wide_fits_in_byte (c))
- {
- gfc_error ("Invalid Hollerith constant at %L contains a "
- "wide character", &old_loc);
- goto cleanup;
- }
-
- e->representation.string[i] = (unsigned char) c;
- }
-
- /* Now pad with blanks and end with a null char. */
- for (i = 0; i < pad; i++)
- e->representation.string[num + i] = ' ';
-
- e->representation.string[num + i] = '\0';
- e->representation.length = num + pad;
- e->ts.u.pad = pad;
-
- *result = e;
- return MATCH_YES;
- }
- }
-
- gfc_free_expr (e);
- gfc_current_locus = old_loc;
- return MATCH_NO;
-
-cleanup:
- gfc_free_expr (e);
- return MATCH_ERROR;
-}
-
-
-/* Match a binary, octal or hexadecimal constant that can be found in
- a DATA statement. The standard permits b'010...', o'73...', and
- z'a1...' where b, o, and z can be capital letters. This function
- also accepts postfixed forms of the constants: '01...'b, '73...'o,
- and 'a1...'z. An additional extension is the use of x for z. */
-
-static match
-match_boz_constant (gfc_expr **result)
-{
- int radix, length, x_hex;
- locus old_loc, start_loc;
- char *buffer, post, delim;
- gfc_expr *e;
-
- start_loc = old_loc = gfc_current_locus;
- gfc_gobble_whitespace ();
-
- x_hex = 0;
- switch (post = gfc_next_ascii_char ())
- {
- case 'b':
- radix = 2;
- post = 0;
- break;
- case 'o':
- radix = 8;
- post = 0;
- break;
- case 'x':
- x_hex = 1;
- /* Fall through. */
- case 'z':
- radix = 16;
- post = 0;
- break;
- case '\'':
- /* Fall through. */
- case '\"':
- delim = post;
- post = 1;
- radix = 16; /* Set to accept any valid digit string. */
- break;
- default:
- goto backup;
- }
-
- /* No whitespace allowed here. */
-
- if (post == 0)
- delim = gfc_next_ascii_char ();
-
- if (delim != '\'' && delim != '\"')
- goto backup;
-
- if (x_hex
- && gfc_invalid_boz (G_("Hexadecimal constant at %L uses "
- "nonstandard X instead of Z"), &gfc_current_locus))
- return MATCH_ERROR;
-
- old_loc = gfc_current_locus;
-
- length = match_digits (0, radix, NULL);
- if (length == -1)
- {
- gfc_error ("Empty set of digits in BOZ constant at %C");
- return MATCH_ERROR;
- }
-
- if (gfc_next_ascii_char () != delim)
- {
- gfc_error ("Illegal character in BOZ constant at %C");
- return MATCH_ERROR;
- }
-
- if (post == 1)
- {
- switch (gfc_next_ascii_char ())
- {
- case 'b':
- radix = 2;
- break;
- case 'o':
- radix = 8;
- break;
- case 'x':
- /* Fall through. */
- case 'z':
- radix = 16;
- break;
- default:
- goto backup;
- }
-
- if (gfc_invalid_boz (G_("BOZ constant at %C uses nonstandard postfix "
- "syntax"), &gfc_current_locus))
- return MATCH_ERROR;
- }
-
- gfc_current_locus = old_loc;
-
- buffer = (char *) alloca (length + 1);
- memset (buffer, '\0', length + 1);
-
- match_digits (0, radix, buffer);
- gfc_next_ascii_char (); /* Eat delimiter. */
- if (post == 1)
- gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */
-
- e = gfc_get_expr ();
- e->expr_type = EXPR_CONSTANT;
- e->ts.type = BT_BOZ;
- e->where = gfc_current_locus;
- e->boz.rdx = radix;
- e->boz.len = length;
- e->boz.str = XCNEWVEC (char, length + 1);
- strncpy (e->boz.str, buffer, length);
-
- if (!gfc_in_match_data ()
- && (!gfc_notify_std(GFC_STD_F2003, "BOZ used outside a DATA "
- "statement at %L", &e->where)))
- return MATCH_ERROR;
-
- *result = e;
- return MATCH_YES;
-
-backup:
- gfc_current_locus = start_loc;
- return MATCH_NO;
-}
-
-
-/* Match a real constant of some sort. Allow a signed constant if signflag
- is nonzero. */
-
-static match
-match_real_constant (gfc_expr **result, int signflag)
-{
- int kind, count, seen_dp, seen_digits, is_iso_c, default_exponent;
- locus old_loc, temp_loc;
- char *p, *buffer, c, exp_char;
- gfc_expr *e;
- bool negate;
-
- old_loc = gfc_current_locus;
- gfc_gobble_whitespace ();
-
- e = NULL;
-
- default_exponent = 0;
- count = 0;
- seen_dp = 0;
- seen_digits = 0;
- exp_char = ' ';
- negate = FALSE;
-
- c = gfc_next_ascii_char ();
- if (signflag && (c == '+' || c == '-'))
- {
- if (c == '-')
- negate = TRUE;
-
- gfc_gobble_whitespace ();
- c = gfc_next_ascii_char ();
- }
-
- /* Scan significand. */
- for (;; c = gfc_next_ascii_char (), count++)
- {
- if (c == '.')
- {
- if (seen_dp)
- goto done;
-
- /* Check to see if "." goes with a following operator like
- ".eq.". */
- temp_loc = gfc_current_locus;
- c = gfc_next_ascii_char ();
-
- if (c == 'e' || c == 'd' || c == 'q')
- {
- c = gfc_next_ascii_char ();
- if (c == '.')
- goto done; /* Operator named .e. or .d. */
- }
-
- if (ISALPHA (c))
- goto done; /* Distinguish 1.e9 from 1.eq.2 */
-
- gfc_current_locus = temp_loc;
- seen_dp = 1;
- continue;
- }
-
- if (ISDIGIT (c))
- {
- seen_digits = 1;
- continue;
- }
-
- break;
- }
-
- if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
- goto done;
- exp_char = c;
-
-
- if (c == 'q')
- {
- if (!gfc_notify_std (GFC_STD_GNU, "exponent-letter 'q' in "
- "real-literal-constant at %C"))
- return MATCH_ERROR;
- else if (warn_real_q_constant)
- gfc_warning (OPT_Wreal_q_constant,
- "Extension: exponent-letter %<q%> in real-literal-constant "
- "at %C");
- }
-
- /* Scan exponent. */
- c = gfc_next_ascii_char ();
- count++;
-
- if (c == '+' || c == '-')
- { /* optional sign */
- c = gfc_next_ascii_char ();
- count++;
- }
-
- if (!ISDIGIT (c))
- {
- /* With -fdec, default exponent to 0 instead of complaining. */
- if (flag_dec)
- default_exponent = 1;
- else
- {
- gfc_error ("Missing exponent in real number at %C");
- return MATCH_ERROR;
- }
- }
-
- while (ISDIGIT (c))
- {
- c = gfc_next_ascii_char ();
- count++;
- }
-
-done:
- /* Check that we have a numeric constant. */
- if (!seen_digits || (!seen_dp && exp_char == ' '))
- {
- gfc_current_locus = old_loc;
- return MATCH_NO;
- }
-
- /* Convert the number. */
- gfc_current_locus = old_loc;
- gfc_gobble_whitespace ();
-
- buffer = (char *) alloca (count + default_exponent + 1);
- memset (buffer, '\0', count + default_exponent + 1);
-
- p = buffer;
- c = gfc_next_ascii_char ();
- if (c == '+' || c == '-')
- {
- gfc_gobble_whitespace ();
- c = gfc_next_ascii_char ();
- }
-
- /* Hack for mpfr_set_str(). */
- for (;;)
- {
- if (c == 'd' || c == 'q')
- *p = 'e';
- else
- *p = c;
- p++;
- if (--count == 0)
- break;
-
- c = gfc_next_ascii_char ();
- }
- if (default_exponent)
- *p++ = '0';
-
- kind = get_kind (&is_iso_c);
- if (kind == -1)
- goto cleanup;
-
- if (kind == 4)
- {
- if (flag_real4_kind == 8)
- kind = 8;
- if (flag_real4_kind == 10)
- kind = 10;
- if (flag_real4_kind == 16)
- kind = 16;
- }
- else if (kind == 8)
- {
- if (flag_real8_kind == 4)
- kind = 4;
- if (flag_real8_kind == 10)
- kind = 10;
- if (flag_real8_kind == 16)
- kind = 16;
- }
-
- switch (exp_char)
- {
- case 'd':
- if (kind != -2)
- {
- gfc_error ("Real number at %C has a %<d%> exponent and an explicit "
- "kind");
- goto cleanup;
- }
- kind = gfc_default_double_kind;
- break;
-
- case 'q':
- if (kind != -2)
- {
- gfc_error ("Real number at %C has a %<q%> exponent and an explicit "
- "kind");
- goto cleanup;
- }
-
- /* The maximum possible real kind type parameter is 16. First, try
- that for the kind, then fallback to trying kind=10 (Intel 80 bit)
- extended precision. If neither value works, just given up. */
- kind = 16;
- if (gfc_validate_kind (BT_REAL, kind, true) < 0)
- {
- kind = 10;
- if (gfc_validate_kind (BT_REAL, kind, true) < 0)
- {
- gfc_error ("Invalid exponent-letter %<q%> in "
- "real-literal-constant at %C");
- goto cleanup;
- }
- }
- break;
-
- default:
- if (kind == -2)
- kind = gfc_default_real_kind;
-
- if (gfc_validate_kind (BT_REAL, kind, true) < 0)
- {
- gfc_error ("Invalid real kind %d at %C", kind);
- goto cleanup;
- }
- }
-
- e = convert_real (buffer, kind, &gfc_current_locus);
- if (negate)
- mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
- e->ts.is_c_interop = is_iso_c;
-
- switch (gfc_range_check (e))
- {
- case ARITH_OK:
- break;
- case ARITH_OVERFLOW:
- gfc_error ("Real constant overflows its kind at %C");
- goto cleanup;
-
- case ARITH_UNDERFLOW:
- if (warn_underflow)
- gfc_warning (OPT_Wunderflow, "Real constant underflows its kind at %C");
- mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
- break;
-
- default:
- gfc_internal_error ("gfc_range_check() returned bad value");
- }
-
- /* Warn about trailing digits which suggest the user added too many
- trailing digits, which may cause the appearance of higher pecision
- than the kind kan support.
-
- This is done by replacing the rightmost non-zero digit with zero
- and comparing with the original value. If these are equal, we
- assume the user supplied more digits than intended (or forgot to
- convert to the correct kind).
- */
-
- if (warn_conversion_extra)
- {
- mpfr_t r;
- char *c1;
- bool did_break;
-
- c1 = strchr (buffer, 'e');
- if (c1 == NULL)
- c1 = buffer + strlen(buffer);
-
- did_break = false;
- for (p = c1; p > buffer;)
- {
- p--;
- if (*p == '.')
- continue;
-
- if (*p != '0')
- {
- *p = '0';
- did_break = true;
- break;
- }
- }
-
- if (did_break)
- {
- mpfr_init (r);
- mpfr_set_str (r, buffer, 10, GFC_RND_MODE);
- if (negate)
- mpfr_neg (r, r, GFC_RND_MODE);
-
- mpfr_sub (r, r, e->value.real, GFC_RND_MODE);
-
- if (mpfr_cmp_ui (r, 0) == 0)
- gfc_warning (OPT_Wconversion_extra, "Non-significant digits "
- "in %qs number at %C, maybe incorrect KIND",
- gfc_typename (&e->ts));
-
- mpfr_clear (r);
- }
- }
-
- *result = e;
- return MATCH_YES;
-
-cleanup:
- gfc_free_expr (e);
- return MATCH_ERROR;
-}
-
-
-/* Match a substring reference. */
-
-static match
-match_substring (gfc_charlen *cl, int init, gfc_ref **result, bool deferred)
-{
- gfc_expr *start, *end;
- locus old_loc;
- gfc_ref *ref;
- match m;
-
- start = NULL;
- end = NULL;
-
- old_loc = gfc_current_locus;
-
- m = gfc_match_char ('(');
- if (m != MATCH_YES)
- return MATCH_NO;
-
- if (gfc_match_char (':') != MATCH_YES)
- {
- if (init)
- m = gfc_match_init_expr (&start);
- else
- m = gfc_match_expr (&start);
-
- if (m != MATCH_YES)
- {
- m = MATCH_NO;
- goto cleanup;
- }
-
- m = gfc_match_char (':');
- if (m != MATCH_YES)
- goto cleanup;
- }
-
- if (gfc_match_char (')') != MATCH_YES)
- {
- if (init)
- m = gfc_match_init_expr (&end);
- else
- m = gfc_match_expr (&end);
-
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- m = gfc_match_char (')');
- if (m == MATCH_NO)
- goto syntax;
- }
-
- /* Optimize away the (:) reference. */
- if (start == NULL && end == NULL && !deferred)
- ref = NULL;
- else
- {
- ref = gfc_get_ref ();
-
- ref->type = REF_SUBSTRING;
- if (start == NULL)
- start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
- ref->u.ss.start = start;
- if (end == NULL && cl)
- end = gfc_copy_expr (cl->length);
- ref->u.ss.end = end;
- ref->u.ss.length = cl;
- }
-
- *result = ref;
- return MATCH_YES;
-
-syntax:
- gfc_error ("Syntax error in SUBSTRING specification at %C");
- m = MATCH_ERROR;
-
-cleanup:
- gfc_free_expr (start);
- gfc_free_expr (end);
-
- gfc_current_locus = old_loc;
- return m;
-}
-
-
-/* Reads the next character of a string constant, taking care to
- return doubled delimiters on the input as a single instance of
- the delimiter.
-
- Special return values for "ret" argument are:
- -1 End of the string, as determined by the delimiter
- -2 Unterminated string detected
-
- Backslash codes are also expanded at this time. */
-
-static gfc_char_t
-next_string_char (gfc_char_t delimiter, int *ret)
-{
- locus old_locus;
- gfc_char_t c;
-
- c = gfc_next_char_literal (INSTRING_WARN);
- *ret = 0;
-
- if (c == '\n')
- {
- *ret = -2;
- return 0;
- }
-
- if (flag_backslash && c == '\\')
- {
- old_locus = gfc_current_locus;
-
- if (gfc_match_special_char (&c) == MATCH_NO)
- gfc_current_locus = old_locus;
-
- if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
- gfc_warning (0, "Extension: backslash character at %C");
- }
-
- if (c != delimiter)
- return c;
-
- old_locus = gfc_current_locus;
- c = gfc_next_char_literal (NONSTRING);
-
- if (c == delimiter)
- return c;
- gfc_current_locus = old_locus;
-
- *ret = -1;
- return 0;
-}
-
-
-/* Special case of gfc_match_name() that matches a parameter kind name
- before a string constant. This takes case of the weird but legal
- case of:
-
- kind_____'string'
-
- where kind____ is a parameter. gfc_match_name() will happily slurp
- up all the underscores, which leads to problems. If we return
- MATCH_YES, the parse pointer points to the final underscore, which
- is not part of the name. We never return MATCH_ERROR-- errors in
- the name will be detected later. */
-
-static match
-match_charkind_name (char *name)
-{
- locus old_loc;
- char c, peek;
- int len;
-
- gfc_gobble_whitespace ();
- c = gfc_next_ascii_char ();
- if (!ISALPHA (c))
- return MATCH_NO;
-
- *name++ = c;
- len = 1;
-
- for (;;)
- {
- old_loc = gfc_current_locus;
- c = gfc_next_ascii_char ();
-
- if (c == '_')
- {
- peek = gfc_peek_ascii_char ();
-
- if (peek == '\'' || peek == '\"')
- {
- gfc_current_locus = old_loc;
- *name = '\0';
- return MATCH_YES;
- }
- }
-
- if (!ISALNUM (c)
- && c != '_'
- && (c != '$' || !flag_dollar_ok))
- break;
-
- *name++ = c;
- if (++len > GFC_MAX_SYMBOL_LEN)
- break;
- }
-
- return MATCH_NO;
-}
-
-
-/* See if the current input matches a character constant. Lots of
- contortions have to be done to match the kind parameter which comes
- before the actual string. The main consideration is that we don't
- want to error out too quickly. For example, we don't actually do
- any validation of the kinds until we have actually seen a legal
- delimiter. Using match_kind_param() generates errors too quickly. */
-
-static match
-match_string_constant (gfc_expr **result)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1], peek;
- size_t length;
- int kind,save_warn_ampersand, ret;
- locus old_locus, start_locus;
- gfc_symbol *sym;
- gfc_expr *e;
- match m;
- gfc_char_t c, delimiter, *p;
-
- old_locus = gfc_current_locus;
-
- gfc_gobble_whitespace ();
-
- c = gfc_next_char ();
- if (c == '\'' || c == '"')
- {
- kind = gfc_default_character_kind;
- start_locus = gfc_current_locus;
- goto got_delim;
- }
-
- if (gfc_wide_is_digit (c))
- {
- kind = 0;
-
- while (gfc_wide_is_digit (c))
- {
- kind = kind * 10 + c - '0';
- if (kind > 9999999)
- goto no_match;
- c = gfc_next_char ();
- }
-
- }
- else
- {
- gfc_current_locus = old_locus;
-
- m = match_charkind_name (name);
- if (m != MATCH_YES)
- goto no_match;
-
- if (gfc_find_symbol (name, NULL, 1, &sym)
- || sym == NULL
- || sym->attr.flavor != FL_PARAMETER)
- goto no_match;
-
- kind = -1;
- c = gfc_next_char ();
- }
-
- if (c == ' ')
- {
- gfc_gobble_whitespace ();
- c = gfc_next_char ();
- }
-
- if (c != '_')
- goto no_match;
-
- gfc_gobble_whitespace ();
-
- c = gfc_next_char ();
- if (c != '\'' && c != '"')
- goto no_match;
-
- start_locus = gfc_current_locus;
-
- if (kind == -1)
- {
- if (gfc_extract_int (sym->value, &kind, 1))
- return MATCH_ERROR;
- gfc_set_sym_referenced (sym);
- }
-
- if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
- {
- gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
- return MATCH_ERROR;
- }
-
-got_delim:
- /* Scan the string into a block of memory by first figuring out how
- long it is, allocating the structure, then re-reading it. This
- isn't particularly efficient, but string constants aren't that
- common in most code. TODO: Use obstacks? */
-
- delimiter = c;
- length = 0;
-
- for (;;)
- {
- c = next_string_char (delimiter, &ret);
- if (ret == -1)
- break;
- if (ret == -2)
- {
- gfc_current_locus = start_locus;
- gfc_error ("Unterminated character constant beginning at %C");
- return MATCH_ERROR;
- }
-
- length++;
- }
-
- /* Peek at the next character to see if it is a b, o, z, or x for the
- postfixed BOZ literal constants. */
- peek = gfc_peek_ascii_char ();
- if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x')
- goto no_match;
-
- e = gfc_get_character_expr (kind, &start_locus, NULL, length);
-
- gfc_current_locus = start_locus;
-
- /* We disable the warning for the following loop as the warning has already
- been printed in the loop above. */
- save_warn_ampersand = warn_ampersand;
- warn_ampersand = false;
-
- p = e->value.character.string;
- for (size_t i = 0; i < length; i++)
- {
- c = next_string_char (delimiter, &ret);
-
- if (!gfc_check_character_range (c, kind))
- {
- gfc_free_expr (e);
- gfc_error ("Character %qs in string at %C is not representable "
- "in character kind %d", gfc_print_wide_char (c), kind);
- return MATCH_ERROR;
- }
-
- *p++ = c;
- }
-
- *p = '\0'; /* TODO: C-style string is for development/debug purposes. */
- warn_ampersand = save_warn_ampersand;
-
- next_string_char (delimiter, &ret);
- if (ret != -1)
- gfc_internal_error ("match_string_constant(): Delimiter not found");
-
- if (match_substring (NULL, 0, &e->ref, false) != MATCH_NO)
- e->expr_type = EXPR_SUBSTRING;
-
- /* Substrings with constant starting and ending points are eligible as
- designators (F2018, section 9.1). Simplify substrings to make them usable
- e.g. in data statements. */
- if (e->expr_type == EXPR_SUBSTRING
- && e->ref && e->ref->type == REF_SUBSTRING
- && e->ref->u.ss.start->expr_type == EXPR_CONSTANT
- && (e->ref->u.ss.end == NULL
- || e->ref->u.ss.end->expr_type == EXPR_CONSTANT))
- {
- gfc_expr *res;
- ptrdiff_t istart, iend;
- size_t length;
- bool equal_length = false;
-
- /* Basic checks on substring starting and ending indices. */
- if (!gfc_resolve_substring (e->ref, &equal_length))
- return MATCH_ERROR;
-
- length = e->value.character.length;
- istart = gfc_mpz_get_hwi (e->ref->u.ss.start->value.integer);
- if (e->ref->u.ss.end == NULL)
- iend = length;
- else
- iend = gfc_mpz_get_hwi (e->ref->u.ss.end->value.integer);
-
- if (istart <= iend)
- {
- if (istart < 1)
- {
- gfc_error ("Substring start index (%ld) at %L below 1",
- (long) istart, &e->ref->u.ss.start->where);
- return MATCH_ERROR;
- }
- if (iend > (ssize_t) length)
- {
- gfc_error ("Substring end index (%ld) at %L exceeds string "
- "length", (long) iend, &e->ref->u.ss.end->where);
- return MATCH_ERROR;
- }
- length = iend - istart + 1;
- }
- else
- length = 0;
-
- res = gfc_get_constant_expr (BT_CHARACTER, e->ts.kind, &e->where);
- res->value.character.string = gfc_get_wide_string (length + 1);
- res->value.character.length = length;
- if (length > 0)
- memcpy (res->value.character.string,
- &e->value.character.string[istart - 1],
- length * sizeof (gfc_char_t));
- res->value.character.string[length] = '\0';
- e = res;
- }
-
- *result = e;
-
- return MATCH_YES;
-
-no_match:
- gfc_current_locus = old_locus;
- return MATCH_NO;
-}
-
-
-/* Match a .true. or .false. Returns 1 if a .true. was found,
- 0 if a .false. was found, and -1 otherwise. */
-static int
-match_logical_constant_string (void)
-{
- locus orig_loc = gfc_current_locus;
-
- gfc_gobble_whitespace ();
- if (gfc_next_ascii_char () == '.')
- {
- char ch = gfc_next_ascii_char ();
- if (ch == 'f')
- {
- if (gfc_next_ascii_char () == 'a'
- && gfc_next_ascii_char () == 'l'
- && gfc_next_ascii_char () == 's'
- && gfc_next_ascii_char () == 'e'
- && gfc_next_ascii_char () == '.')
- /* Matched ".false.". */
- return 0;
- }
- else if (ch == 't')
- {
- if (gfc_next_ascii_char () == 'r'
- && gfc_next_ascii_char () == 'u'
- && gfc_next_ascii_char () == 'e'
- && gfc_next_ascii_char () == '.')
- /* Matched ".true.". */
- return 1;
- }
- }
- gfc_current_locus = orig_loc;
- return -1;
-}
-
-/* Match a .true. or .false. */
-
-static match
-match_logical_constant (gfc_expr **result)
-{
- gfc_expr *e;
- int i, kind, is_iso_c;
-
- i = match_logical_constant_string ();
- if (i == -1)
- return MATCH_NO;
-
- kind = get_kind (&is_iso_c);
- if (kind == -1)
- return MATCH_ERROR;
- if (kind == -2)
- kind = gfc_default_logical_kind;
-
- if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
- {
- gfc_error ("Bad kind for logical constant at %C");
- return MATCH_ERROR;
- }
-
- e = gfc_get_logical_expr (kind, &gfc_current_locus, i);
- e->ts.is_c_interop = is_iso_c;
-
- *result = e;
- return MATCH_YES;
-}
-
-
-/* Match a real or imaginary part of a complex constant that is a
- symbolic constant. */
-
-static match
-match_sym_complex_part (gfc_expr **result)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_symbol *sym;
- gfc_expr *e;
- match m;
-
- m = gfc_match_name (name);
- if (m != MATCH_YES)
- return m;
-
- if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
- return MATCH_NO;
-
- if (sym->attr.flavor != FL_PARAMETER)
- {
- /* Give the matcher for implied do-loops a chance to run. This yields
- a much saner error message for "write(*,*) (i, i=1, 6" where the
- right parenthesis is missing. */
- char c;
- gfc_gobble_whitespace ();
- c = gfc_peek_ascii_char ();
- if (c == '=' || c == ',')
- {
- m = MATCH_NO;
- }
- else
- {
- gfc_error ("Expected PARAMETER symbol in complex constant at %C");
- m = MATCH_ERROR;
- }
- return m;
- }
-
- if (!sym->value)
- goto error;
-
- if (!gfc_numeric_ts (&sym->value->ts))
- {
- gfc_error ("Numeric PARAMETER required in complex constant at %C");
- return MATCH_ERROR;
- }
-
- if (sym->value->rank != 0)
- {
- gfc_error ("Scalar PARAMETER required in complex constant at %C");
- return MATCH_ERROR;
- }
-
- if (!gfc_notify_std (GFC_STD_F2003, "PARAMETER symbol in "
- "complex constant at %C"))
- return MATCH_ERROR;
-
- switch (sym->value->ts.type)
- {
- case BT_REAL:
- e = gfc_copy_expr (sym->value);
- break;
-
- case BT_COMPLEX:
- e = gfc_complex2real (sym->value, sym->value->ts.kind);
- if (e == NULL)
- goto error;
- break;
-
- case BT_INTEGER:
- e = gfc_int2real (sym->value, gfc_default_real_kind);
- if (e == NULL)
- goto error;
- break;
-
- default:
- gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
- }
-
- *result = e; /* e is a scalar, real, constant expression. */
- return MATCH_YES;
-
-error:
- gfc_error ("Error converting PARAMETER constant in complex constant at %C");
- return MATCH_ERROR;
-}
-
-
-/* Match a real or imaginary part of a complex number. */
-
-static match
-match_complex_part (gfc_expr **result)
-{
- match m;
-
- m = match_sym_complex_part (result);
- if (m != MATCH_NO)
- return m;
-
- m = match_real_constant (result, 1);
- if (m != MATCH_NO)
- return m;
-
- return match_integer_constant (result, 1);
-}
-
-
-/* Try to match a complex constant. */
-
-static match
-match_complex_constant (gfc_expr **result)
-{
- gfc_expr *e, *real, *imag;
- gfc_error_buffer old_error;
- gfc_typespec target;
- locus old_loc;
- int kind;
- match m;
-
- old_loc = gfc_current_locus;
- real = imag = e = NULL;
-
- m = gfc_match_char ('(');
- if (m != MATCH_YES)
- return m;
-
- gfc_push_error (&old_error);
-
- m = match_complex_part (&real);
- if (m == MATCH_NO)
- {
- gfc_free_error (&old_error);
- goto cleanup;
- }
-
- if (gfc_match_char (',') == MATCH_NO)
- {
- /* It is possible that gfc_int2real issued a warning when
- converting an integer to real. Throw this away here. */
-
- gfc_clear_warning ();
- gfc_pop_error (&old_error);
- m = MATCH_NO;
- goto cleanup;
- }
-
- /* If m is error, then something was wrong with the real part and we
- assume we have a complex constant because we've seen the ','. An
- ambiguous case here is the start of an iterator list of some
- sort. These sort of lists are matched prior to coming here. */
-
- if (m == MATCH_ERROR)
- {
- gfc_free_error (&old_error);
- goto cleanup;
- }
- gfc_pop_error (&old_error);
-
- m = match_complex_part (&imag);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- m = gfc_match_char (')');
- if (m == MATCH_NO)
- {
- /* Give the matcher for implied do-loops a chance to run. This
- yields a much saner error message for (/ (i, 4=i, 6) /). */
- if (gfc_peek_ascii_char () == '=')
- {
- m = MATCH_ERROR;
- goto cleanup;
- }
- else
- goto syntax;
- }
-
- if (m == MATCH_ERROR)
- goto cleanup;
-
- /* Decide on the kind of this complex number. */
- if (real->ts.type == BT_REAL)
- {
- if (imag->ts.type == BT_REAL)
- kind = gfc_kind_max (real, imag);
- else
- kind = real->ts.kind;
- }
- else
- {
- if (imag->ts.type == BT_REAL)
- kind = imag->ts.kind;
- else
- kind = gfc_default_real_kind;
- }
- gfc_clear_ts (&target);
- target.type = BT_REAL;
- target.kind = kind;
-
- if (real->ts.type != BT_REAL || kind != real->ts.kind)
- gfc_convert_type (real, &target, 2);
- if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
- gfc_convert_type (imag, &target, 2);
-
- e = convert_complex (real, imag, kind);
- e->where = gfc_current_locus;
-
- gfc_free_expr (real);
- gfc_free_expr (imag);
-
- *result = e;
- return MATCH_YES;
-
-syntax:
- gfc_error ("Syntax error in COMPLEX constant at %C");
- m = MATCH_ERROR;
-
-cleanup:
- gfc_free_expr (e);
- gfc_free_expr (real);
- gfc_free_expr (imag);
- gfc_current_locus = old_loc;
-
- return m;
-}
-
-
-/* Match constants in any of several forms. Returns nonzero for a
- match, zero for no match. */
-
-match
-gfc_match_literal_constant (gfc_expr **result, int signflag)
-{
- match m;
-
- m = match_complex_constant (result);
- if (m != MATCH_NO)
- return m;
-
- m = match_string_constant (result);
- if (m != MATCH_NO)
- return m;
-
- m = match_boz_constant (result);
- if (m != MATCH_NO)
- return m;
-
- m = match_real_constant (result, signflag);
- if (m != MATCH_NO)
- return m;
-
- m = match_hollerith_constant (result);
- if (m != MATCH_NO)
- return m;
-
- m = match_integer_constant (result, signflag);
- if (m != MATCH_NO)
- return m;
-
- m = match_logical_constant (result);
- if (m != MATCH_NO)
- return m;
-
- return MATCH_NO;
-}
-
-
-/* This checks if a symbol is the return value of an encompassing function.
- Function nesting can be maximally two levels deep, but we may have
- additional local namespaces like BLOCK etc. */
-
-bool
-gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
-{
- if (!sym->attr.function || (sym->result != sym))
- return false;
- while (ns)
- {
- if (ns->proc_name == sym)
- return true;
- ns = ns->parent;
- }
- return false;
-}
-
-
-/* Match a single actual argument value. An actual argument is
- usually an expression, but can also be a procedure name. If the
- argument is a single name, it is not always possible to tell
- whether the name is a dummy procedure or not. We treat these cases
- by creating an argument that looks like a dummy procedure and
- fixing things later during resolution. */
-
-static match
-match_actual_arg (gfc_expr **result)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_symtree *symtree;
- locus where, w;
- gfc_expr *e;
- char c;
-
- gfc_gobble_whitespace ();
- where = gfc_current_locus;
-
- switch (gfc_match_name (name))
- {
- case MATCH_ERROR:
- return MATCH_ERROR;
-
- case MATCH_NO:
- break;
-
- case MATCH_YES:
- w = gfc_current_locus;
- gfc_gobble_whitespace ();
- c = gfc_next_ascii_char ();
- gfc_current_locus = w;
-
- if (c != ',' && c != ')')
- break;
-
- if (gfc_find_sym_tree (name, NULL, 1, &symtree))
- break;
- /* Handle error elsewhere. */
-
- /* Eliminate a couple of common cases where we know we don't
- have a function argument. */
- if (symtree == NULL)
- {
- gfc_get_sym_tree (name, NULL, &symtree, false);
- gfc_set_sym_referenced (symtree->n.sym);
- }
- else
- {
- gfc_symbol *sym;
-
- sym = symtree->n.sym;
- gfc_set_sym_referenced (sym);
- if (sym->attr.flavor == FL_NAMELIST)
- {
- gfc_error ("Namelist %qs cannot be an argument at %L",
- sym->name, &where);
- break;
- }
- if (sym->attr.flavor != FL_PROCEDURE
- && sym->attr.flavor != FL_UNKNOWN)
- break;
-
- if (sym->attr.in_common && !sym->attr.proc_pointer)
- {
- if (!gfc_add_flavor (&sym->attr, FL_VARIABLE,
- sym->name, &sym->declared_at))
- return MATCH_ERROR;
- break;
- }
-
- /* If the symbol is a function with itself as the result and
- is being defined, then we have a variable. */
- if (sym->attr.function && sym->result == sym)
- {
- if (gfc_is_function_return_value (sym, gfc_current_ns))
- break;
-
- if (sym->attr.entry
- && (sym->ns == gfc_current_ns
- || sym->ns == gfc_current_ns->parent))
- {
- gfc_entry_list *el = NULL;
-
- for (el = sym->ns->entries; el; el = el->next)
- if (sym == el->sym)
- break;
-
- if (el)
- break;
- }
- }
- }
-
- e = gfc_get_expr (); /* Leave it unknown for now */
- e->symtree = symtree;
- e->expr_type = EXPR_VARIABLE;
- e->ts.type = BT_PROCEDURE;
- e->where = where;
-
- *result = e;
- return MATCH_YES;
- }
-
- gfc_current_locus = where;
- return gfc_match_expr (result);
-}
-
-
-/* Match a keyword argument or type parameter spec list.. */
-
-static match
-match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base, bool pdt)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_actual_arglist *a;
- locus name_locus;
- match m;
-
- name_locus = gfc_current_locus;
- m = gfc_match_name (name);
-
- if (m != MATCH_YES)
- goto cleanup;
- if (gfc_match_char ('=') != MATCH_YES)
- {
- m = MATCH_NO;
- goto cleanup;
- }
-
- if (pdt)
- {
- if (gfc_match_char ('*') == MATCH_YES)
- {
- actual->spec_type = SPEC_ASSUMED;
- goto add_name;
- }
- else if (gfc_match_char (':') == MATCH_YES)
- {
- actual->spec_type = SPEC_DEFERRED;
- goto add_name;
- }
- else
- actual->spec_type = SPEC_EXPLICIT;
- }
-
- m = match_actual_arg (&actual->expr);
- if (m != MATCH_YES)
- goto cleanup;
-
- /* Make sure this name has not appeared yet. */
-add_name:
- if (name[0] != '\0')
- {
- for (a = base; a; a = a->next)
- if (a->name != NULL && strcmp (a->name, name) == 0)
- {
- gfc_error ("Keyword %qs at %C has already appeared in the "
- "current argument list", name);
- return MATCH_ERROR;
- }
- }
-
- actual->name = gfc_get_string ("%s", name);
- return MATCH_YES;
-
-cleanup:
- gfc_current_locus = name_locus;
- return m;
-}
-
-
-/* Match an argument list function, such as %VAL. */
-
-static match
-match_arg_list_function (gfc_actual_arglist *result)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- locus old_locus;
- match m;
-
- old_locus = gfc_current_locus;
-
- if (gfc_match_char ('%') != MATCH_YES)
- {
- m = MATCH_NO;
- goto cleanup;
- }
-
- m = gfc_match ("%n (", name);
- if (m != MATCH_YES)
- goto cleanup;
-
- if (name[0] != '\0')
- {
- switch (name[0])
- {
- case 'l':
- if (startswith (name, "loc"))
- {
- result->name = "%LOC";
- break;
- }
- /* FALLTHRU */
- case 'r':
- if (startswith (name, "ref"))
- {
- result->name = "%REF";
- break;
- }
- /* FALLTHRU */
- case 'v':
- if (startswith (name, "val"))
- {
- result->name = "%VAL";
- break;
- }
- /* FALLTHRU */
- default:
- m = MATCH_ERROR;
- goto cleanup;
- }
- }
-
- if (!gfc_notify_std (GFC_STD_GNU, "argument list function at %C"))
- {
- m = MATCH_ERROR;
- goto cleanup;
- }
-
- m = match_actual_arg (&result->expr);
- if (m != MATCH_YES)
- goto cleanup;
-
- if (gfc_match_char (')') != MATCH_YES)
- {
- m = MATCH_NO;
- goto cleanup;
- }
-
- return MATCH_YES;
-
-cleanup:
- gfc_current_locus = old_locus;
- return m;
-}
-
-
-/* Matches an actual argument list of a function or subroutine, from
- the opening parenthesis to the closing parenthesis. The argument
- list is assumed to allow keyword arguments because we don't know if
- the symbol associated with the procedure has an implicit interface
- or not. We make sure keywords are unique. If sub_flag is set,
- we're matching the argument list of a subroutine.
-
- NOTE: An alternative use for this function is to match type parameter
- spec lists, which are so similar to actual argument lists that the
- machinery can be reused. This use is flagged by the optional argument
- 'pdt'. */
-
-match
-gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp, bool pdt)
-{
- gfc_actual_arglist *head, *tail;
- int seen_keyword;
- gfc_st_label *label;
- locus old_loc;
- match m;
-
- *argp = tail = NULL;
- old_loc = gfc_current_locus;
-
- seen_keyword = 0;
-
- if (gfc_match_char ('(') == MATCH_NO)
- return (sub_flag) ? MATCH_YES : MATCH_NO;
-
- if (gfc_match_char (')') == MATCH_YES)
- return MATCH_YES;
-
- head = NULL;
-
- matching_actual_arglist++;
-
- for (;;)
- {
- if (head == NULL)
- head = tail = gfc_get_actual_arglist ();
- else
- {
- tail->next = gfc_get_actual_arglist ();
- tail = tail->next;
- }
-
- if (sub_flag && !pdt && gfc_match_char ('*') == MATCH_YES)
- {
- m = gfc_match_st_label (&label);
- if (m == MATCH_NO)
- gfc_error ("Expected alternate return label at %C");
- if (m != MATCH_YES)
- goto cleanup;
-
- if (!gfc_notify_std (GFC_STD_F95_OBS, "Alternate-return argument "
- "at %C"))
- goto cleanup;
-
- tail->label = label;
- goto next;
- }
-
- if (pdt && !seen_keyword)
- {
- if (gfc_match_char (':') == MATCH_YES)
- {
- tail->spec_type = SPEC_DEFERRED;
- goto next;
- }
- else if (gfc_match_char ('*') == MATCH_YES)
- {
- tail->spec_type = SPEC_ASSUMED;
- goto next;
- }
- else
- tail->spec_type = SPEC_EXPLICIT;
-
- m = match_keyword_arg (tail, head, pdt);
- if (m == MATCH_YES)
- {
- seen_keyword = 1;
- goto next;
- }
- if (m == MATCH_ERROR)
- goto cleanup;
- }
-
- /* After the first keyword argument is seen, the following
- arguments must also have keywords. */
- if (seen_keyword)
- {
- m = match_keyword_arg (tail, head, pdt);
-
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_NO)
- {
- gfc_error ("Missing keyword name in actual argument list at %C");
- goto cleanup;
- }
-
- }
- else
- {
- /* Try an argument list function, like %VAL. */
- m = match_arg_list_function (tail);
- if (m == MATCH_ERROR)
- goto cleanup;
-
- /* See if we have the first keyword argument. */
- if (m == MATCH_NO)
- {
- m = match_keyword_arg (tail, head, false);
- if (m == MATCH_YES)
- seen_keyword = 1;
- if (m == MATCH_ERROR)
- goto cleanup;
- }
-
- if (m == MATCH_NO)
- {
- /* Try for a non-keyword argument. */
- m = match_actual_arg (&tail->expr);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_NO)
- goto syntax;
- }
- }
-
-
- next:
- if (gfc_match_char (')') == MATCH_YES)
- break;
- if (gfc_match_char (',') != MATCH_YES)
- goto syntax;
- }
-
- *argp = head;
- matching_actual_arglist--;
- return MATCH_YES;
-
-syntax:
- gfc_error ("Syntax error in argument list at %C");
-
-cleanup:
- gfc_free_actual_arglist (head);
- gfc_current_locus = old_loc;
- matching_actual_arglist--;
- return MATCH_ERROR;
-}
-
-
-/* Used by gfc_match_varspec() to extend the reference list by one
- element. */
-
-static gfc_ref *
-extend_ref (gfc_expr *primary, gfc_ref *tail)
-{
- if (primary->ref == NULL)
- primary->ref = tail = gfc_get_ref ();
- else
- {
- if (tail == NULL)
- gfc_internal_error ("extend_ref(): Bad tail");
- tail->next = gfc_get_ref ();
- tail = tail->next;
- }
-
- return tail;
-}
-
-
-/* Used by gfc_match_varspec() to match an inquiry reference. */
-
-static bool
-is_inquiry_ref (const char *name, gfc_ref **ref)
-{
- inquiry_type type;
-
- if (name == NULL)
- return false;
-
- if (ref) *ref = NULL;
-
- if (strcmp (name, "re") == 0)
- type = INQUIRY_RE;
- else if (strcmp (name, "im") == 0)
- type = INQUIRY_IM;
- else if (strcmp (name, "kind") == 0)
- type = INQUIRY_KIND;
- else if (strcmp (name, "len") == 0)
- type = INQUIRY_LEN;
- else
- return false;
-
- if (ref)
- {
- *ref = gfc_get_ref ();
- (*ref)->type = REF_INQUIRY;
- (*ref)->u.i = type;
- }
-
- return true;
-}
-
-
-/* Match any additional specifications associated with the current
- variable like member references or substrings. If equiv_flag is
- set we only match stuff that is allowed inside an EQUIVALENCE
- statement. sub_flag tells whether we expect a type-bound procedure found
- to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
- components, 'ppc_arg' determines whether the PPC may be called (with an
- argument list), or whether it may just be referred to as a pointer. */
-
-match
-gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
- bool ppc_arg)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_ref *substring, *tail, *tmp;
- gfc_component *component = NULL;
- gfc_component *previous = NULL;
- gfc_symbol *sym = primary->symtree->n.sym;
- gfc_expr *tgt_expr = NULL;
- match m;
- bool unknown;
- bool inquiry;
- bool intrinsic;
- locus old_loc;
- char sep;
-
- tail = NULL;
-
- gfc_gobble_whitespace ();
-
- if (gfc_peek_ascii_char () == '[')
- {
- if ((sym->ts.type != BT_CLASS && sym->attr.dimension)
- || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
- && CLASS_DATA (sym)->attr.dimension))
- {
- gfc_error ("Array section designator, e.g. '(:)', is required "
- "besides the coarray designator '[...]' at %C");
- return MATCH_ERROR;
- }
- if ((sym->ts.type != BT_CLASS && !sym->attr.codimension)
- || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
- && !CLASS_DATA (sym)->attr.codimension))
- {
- gfc_error ("Coarray designator at %C but %qs is not a coarray",
- sym->name);
- return MATCH_ERROR;
- }
- }
-
- if (sym->assoc && sym->assoc->target)
- tgt_expr = sym->assoc->target;
-
- /* For associate names, we may not yet know whether they are arrays or not.
- If the selector expression is unambiguously an array; eg. a full array
- or an array section, then the associate name must be an array and we can
- fix it now. Otherwise, if parentheses follow and it is not a character
- type, we have to assume that it actually is one for now. The final
- decision will be made at resolution, of course. */
- if (sym->assoc
- && gfc_peek_ascii_char () == '('
- && sym->ts.type != BT_CLASS
- && !sym->attr.dimension)
- {
- gfc_ref *ref = NULL;
-
- if (!sym->assoc->dangling && tgt_expr)
- {
- if (tgt_expr->expr_type == EXPR_VARIABLE)
- gfc_resolve_expr (tgt_expr);
-
- ref = tgt_expr->ref;
- for (; ref; ref = ref->next)
- if (ref->type == REF_ARRAY
- && (ref->u.ar.type == AR_FULL
- || ref->u.ar.type == AR_SECTION))
- break;
- }
-
- if (ref || (!(sym->assoc->dangling || sym->ts.type == BT_CHARACTER)
- && sym->assoc->st
- && sym->assoc->st->n.sym
- && sym->assoc->st->n.sym->attr.dimension == 0))
- {
- sym->attr.dimension = 1;
- if (sym->as == NULL
- && sym->assoc->st
- && sym->assoc->st->n.sym
- && sym->assoc->st->n.sym->as)
- sym->as = gfc_copy_array_spec (sym->assoc->st->n.sym->as);
- }
- }
- else if (sym->ts.type == BT_CLASS
- && tgt_expr
- && tgt_expr->expr_type == EXPR_VARIABLE
- && sym->ts.u.derived != tgt_expr->ts.u.derived)
- {
- gfc_resolve_expr (tgt_expr);
- if (tgt_expr->rank)
- sym->ts.u.derived = tgt_expr->ts.u.derived;
- }
-
- if ((equiv_flag && gfc_peek_ascii_char () == '(')
- || gfc_peek_ascii_char () == '[' || sym->attr.codimension
- || (sym->attr.dimension && sym->ts.type != BT_CLASS
- && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary)
- && !(gfc_matching_procptr_assignment
- && sym->attr.flavor == FL_PROCEDURE))
- || (sym->ts.type == BT_CLASS && sym->attr.class_ok
- && sym->ts.u.derived && CLASS_DATA (sym)
- && (CLASS_DATA (sym)->attr.dimension
- || CLASS_DATA (sym)->attr.codimension)))
- {
- gfc_array_spec *as;
-
- tail = extend_ref (primary, tail);
- tail->type = REF_ARRAY;
-
- /* In EQUIVALENCE, we don't know yet whether we are seeing
- an array, character variable or array of character
- variables. We'll leave the decision till resolve time. */
-
- if (equiv_flag)
- as = NULL;
- else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
- as = CLASS_DATA (sym)->as;
- else
- as = sym->as;
-
- m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag,
- as ? as->corank : 0);
- if (m != MATCH_YES)
- return m;
-
- gfc_gobble_whitespace ();
- if (equiv_flag && gfc_peek_ascii_char () == '(')
- {
- tail = extend_ref (primary, tail);
- tail->type = REF_ARRAY;
-
- m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0);
- if (m != MATCH_YES)
- return m;
- }
- }
-
- primary->ts = sym->ts;
-
- if (equiv_flag)
- return MATCH_YES;
-
- /* With DEC extensions, member separator may be '.' or '%'. */
- sep = gfc_peek_ascii_char ();
- m = gfc_match_member_sep (sym);
- if (m == MATCH_ERROR)
- return MATCH_ERROR;
-
- inquiry = false;
- if (m == MATCH_YES && sep == '%'
- && primary->ts.type != BT_CLASS
- && primary->ts.type != BT_DERIVED)
- {
- match mm;
- old_loc = gfc_current_locus;
- mm = gfc_match_name (name);
- if (mm == MATCH_YES && is_inquiry_ref (name, &tmp))
- inquiry = true;
- gfc_current_locus = old_loc;
- }
-
- if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES
- && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
- gfc_set_default_type (sym, 0, sym->ns);
-
- /* See if there is a usable typespec in the "no IMPLICIT type" error. */
- if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES)
- {
- bool permissible;
-
- /* These target expressions can be resolved at any time. */
- permissible = tgt_expr && tgt_expr->symtree && tgt_expr->symtree->n.sym
- && (tgt_expr->symtree->n.sym->attr.use_assoc
- || tgt_expr->symtree->n.sym->attr.host_assoc
- || tgt_expr->symtree->n.sym->attr.if_source
- == IFSRC_DECL);
- permissible = permissible
- || (tgt_expr && tgt_expr->expr_type == EXPR_OP);
-
- if (permissible)
- {
- gfc_resolve_expr (tgt_expr);
- sym->ts = tgt_expr->ts;
- }
-
- if (sym->ts.type == BT_UNKNOWN)
- {
- gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name);
- return MATCH_ERROR;
- }
- }
- else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
- && m == MATCH_YES && !inquiry)
- {
- gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C",
- sep, sym->name);
- return MATCH_ERROR;
- }
-
- if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS && !inquiry)
- || m != MATCH_YES)
- goto check_substring;
-
- if (!inquiry)
- sym = sym->ts.u.derived;
- else
- sym = NULL;
-
- for (;;)
- {
- bool t;
- gfc_symtree *tbp;
-
- m = gfc_match_name (name);
- if (m == MATCH_NO)
- gfc_error ("Expected structure component name at %C");
- if (m != MATCH_YES)
- return MATCH_ERROR;
-
- intrinsic = false;
- if (primary->ts.type != BT_CLASS && primary->ts.type != BT_DERIVED)
- {
- inquiry = is_inquiry_ref (name, &tmp);
- if (inquiry)
- sym = NULL;
-
- if (sep == '%')
- {
- if (tmp)
- {
- switch (tmp->u.i)
- {
- case INQUIRY_RE:
- case INQUIRY_IM:
- if (!gfc_notify_std (GFC_STD_F2008,
- "RE or IM part_ref at %C"))
- return MATCH_ERROR;
- break;
-
- case INQUIRY_KIND:
- if (!gfc_notify_std (GFC_STD_F2003,
- "KIND part_ref at %C"))
- return MATCH_ERROR;
- break;
-
- case INQUIRY_LEN:
- if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C"))
- return MATCH_ERROR;
- break;
- }
-
- if ((tmp->u.i == INQUIRY_RE || tmp->u.i == INQUIRY_IM)
- && primary->ts.type != BT_COMPLEX)
- {
- gfc_error ("The RE or IM part_ref at %C must be "
- "applied to a COMPLEX expression");
- return MATCH_ERROR;
- }
- else if (tmp->u.i == INQUIRY_LEN
- && primary->ts.type != BT_CHARACTER)
- {
- gfc_error ("The LEN part_ref at %C must be applied "
- "to a CHARACTER expression");
- return MATCH_ERROR;
- }
- }
- if (primary->ts.type != BT_UNKNOWN)
- intrinsic = true;
- }
- }
- else
- inquiry = false;
-
- if (sym && sym->f2k_derived)
- tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
- else
- tbp = NULL;
-
- if (tbp)
- {
- gfc_symbol* tbp_sym;
-
- if (!t)
- return MATCH_ERROR;
-
- gcc_assert (!tail || !tail->next);
-
- if (!(primary->expr_type == EXPR_VARIABLE
- || (primary->expr_type == EXPR_STRUCTURE
- && primary->symtree && primary->symtree->n.sym
- && primary->symtree->n.sym->attr.flavor)))
- return MATCH_ERROR;
-
- if (tbp->n.tb->is_generic)
- tbp_sym = NULL;
- else
- tbp_sym = tbp->n.tb->u.specific->n.sym;
-
- primary->expr_type = EXPR_COMPCALL;
- primary->value.compcall.tbp = tbp->n.tb;
- primary->value.compcall.name = tbp->name;
- primary->value.compcall.ignore_pass = 0;
- primary->value.compcall.assign = 0;
- primary->value.compcall.base_object = NULL;
- gcc_assert (primary->symtree->n.sym->attr.referenced);
- if (tbp_sym)
- primary->ts = tbp_sym->ts;
- else
- gfc_clear_ts (&primary->ts);
-
- m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
- &primary->value.compcall.actual);
- if (m == MATCH_ERROR)
- return MATCH_ERROR;
- if (m == MATCH_NO)
- {
- if (sub_flag)
- primary->value.compcall.actual = NULL;
- else
- {
- gfc_error ("Expected argument list at %C");
- return MATCH_ERROR;
- }
- }
-
- break;
- }
-
- previous = component;
-
- if (!inquiry && !intrinsic)
- component = gfc_find_component (sym, name, false, false, &tmp);
- else
- component = NULL;
-
- if (intrinsic && !inquiry)
- {
- if (previous)
- gfc_error ("%qs at %C is not an inquiry reference to an intrinsic "
- "type component %qs", name, previous->name);
- else
- gfc_error ("%qs at %C is not an inquiry reference to an intrinsic "
- "type component", name);
- return MATCH_ERROR;
- }
- else if (component == NULL && !inquiry)
- return MATCH_ERROR;
-
- /* Extend the reference chain determined by gfc_find_component or
- is_inquiry_ref. */
- if (primary->ref == NULL)
- primary->ref = tmp;
- else
- {
- /* Set by the for loop below for the last component ref. */
- gcc_assert (tail != NULL);
- tail->next = tmp;
- }
-
- /* The reference chain may be longer than one hop for union
- subcomponents; find the new tail. */
- for (tail = tmp; tail->next; tail = tail->next)
- ;
-
- if (tmp && tmp->type == REF_INQUIRY)
- {
- if (!primary->where.lb || !primary->where.nextc)
- primary->where = gfc_current_locus;
- gfc_simplify_expr (primary, 0);
-
- if (primary->expr_type == EXPR_CONSTANT)
- goto check_done;
-
- switch (tmp->u.i)
- {
- case INQUIRY_RE:
- case INQUIRY_IM:
- if (!gfc_notify_std (GFC_STD_F2008, "RE or IM part_ref at %C"))
- return MATCH_ERROR;
-
- if (primary->ts.type != BT_COMPLEX)
- {
- gfc_error ("The RE or IM part_ref at %C must be "
- "applied to a COMPLEX expression");
- return MATCH_ERROR;
- }
- primary->ts.type = BT_REAL;
- break;
-
- case INQUIRY_LEN:
- if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C"))
- return MATCH_ERROR;
-
- if (primary->ts.type != BT_CHARACTER)
- {
- gfc_error ("The LEN part_ref at %C must be applied "
- "to a CHARACTER expression");
- return MATCH_ERROR;
- }
- primary->ts.u.cl = NULL;
- primary->ts.type = BT_INTEGER;
- primary->ts.kind = gfc_default_integer_kind;
- break;
-
- case INQUIRY_KIND:
- if (!gfc_notify_std (GFC_STD_F2003, "KIND part_ref at %C"))
- return MATCH_ERROR;
-
- if (primary->ts.type == BT_CLASS
- || primary->ts.type == BT_DERIVED)
- {
- gfc_error ("The KIND part_ref at %C must be applied "
- "to an expression of intrinsic type");
- return MATCH_ERROR;
- }
- primary->ts.type = BT_INTEGER;
- primary->ts.kind = gfc_default_integer_kind;
- break;
-
- default:
- gcc_unreachable ();
- }
-
- goto check_done;
- }
-
- primary->ts = component->ts;
-
- if (component->attr.proc_pointer && ppc_arg)
- {
- /* Procedure pointer component call: Look for argument list. */
- m = gfc_match_actual_arglist (sub_flag,
- &primary->value.compcall.actual);
- if (m == MATCH_ERROR)
- return MATCH_ERROR;
-
- if (m == MATCH_NO && !gfc_matching_ptr_assignment
- && !gfc_matching_procptr_assignment && !matching_actual_arglist)
- {
- gfc_error ("Procedure pointer component %qs requires an "
- "argument list at %C", component->name);
- return MATCH_ERROR;
- }
-
- if (m == MATCH_YES)
- primary->expr_type = EXPR_PPC;
-
- break;
- }
-
- if (component->as != NULL && !component->attr.proc_pointer)
- {
- tail = extend_ref (primary, tail);
- tail->type = REF_ARRAY;
-
- m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag,
- component->as->corank);
- if (m != MATCH_YES)
- return m;
- }
- else if (component->ts.type == BT_CLASS && component->attr.class_ok
- && CLASS_DATA (component)->as && !component->attr.proc_pointer)
- {
- tail = extend_ref (primary, tail);
- tail->type = REF_ARRAY;
-
- m = gfc_match_array_ref (&tail->u.ar, CLASS_DATA (component)->as,
- equiv_flag,
- CLASS_DATA (component)->as->corank);
- if (m != MATCH_YES)
- return m;
- }
-
-check_done:
- /* In principle, we could have eg. expr%re%kind so we must allow for
- this possibility. */
- if (gfc_match_char ('%') == MATCH_YES)
- {
- if (component && (component->ts.type == BT_DERIVED
- || component->ts.type == BT_CLASS))
- sym = component->ts.u.derived;
- continue;
- }
- else if (inquiry)
- break;
-
- if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
- || gfc_match_member_sep (component->ts.u.derived) != MATCH_YES)
- break;
-
- if (component->ts.type == BT_DERIVED || component->ts.type == BT_CLASS)
- sym = component->ts.u.derived;
- }
-
-check_substring:
- unknown = false;
- if (primary->ts.type == BT_UNKNOWN && !gfc_fl_struct (sym->attr.flavor))
- {
- if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
- {
- gfc_set_default_type (sym, 0, sym->ns);
- primary->ts = sym->ts;
- unknown = true;
- }
- }
-
- if (primary->ts.type == BT_CHARACTER)
- {
- bool def = primary->ts.deferred == 1;
- switch (match_substring (primary->ts.u.cl, equiv_flag, &substring, def))
- {
- case MATCH_YES:
- if (tail == NULL)
- primary->ref = substring;
- else
- tail->next = substring;
-
- if (primary->expr_type == EXPR_CONSTANT)
- primary->expr_type = EXPR_SUBSTRING;
-
- if (substring)
- primary->ts.u.cl = NULL;
-
- break;
-
- case MATCH_NO:
- if (unknown)
- {
- gfc_clear_ts (&primary->ts);
- gfc_clear_ts (&sym->ts);
- }
- break;
-
- case MATCH_ERROR:
- return MATCH_ERROR;
- }
- }
-
- /* F08:C611. */
- if (primary->ts.type == BT_DERIVED && primary->ref
- && primary->ts.u.derived && primary->ts.u.derived->attr.abstract)
- {
- gfc_error ("Nonpolymorphic reference to abstract type at %C");
- return MATCH_ERROR;
- }
-
- /* F08:C727. */
- if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary))
- {
- gfc_error ("Coindexed procedure-pointer component at %C");
- return MATCH_ERROR;
- }
-
- return MATCH_YES;
-}
-
-
-/* Given an expression that is a variable, figure out what the
- ultimate variable's type and attribute is, traversing the reference
- structures if necessary.
-
- This subroutine is trickier than it looks. We start at the base
- symbol and store the attribute. Component references load a
- completely new attribute.
-
- A couple of rules come into play. Subobjects of targets are always
- targets themselves. If we see a component that goes through a
- pointer, then the expression must also be a target, since the
- pointer is associated with something (if it isn't core will soon be
- dumped). If we see a full part or section of an array, the
- expression is also an array.
-
- We can have at most one full array reference. */
-
-symbol_attribute
-gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
-{
- int dimension, codimension, pointer, allocatable, target, optional;
- symbol_attribute attr;
- gfc_ref *ref;
- gfc_symbol *sym;
- gfc_component *comp;
- bool has_inquiry_part;
-
- if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
- gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
-
- sym = expr->symtree->n.sym;
- attr = sym->attr;
-
- optional = attr.optional;
- if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived)
- {
- dimension = CLASS_DATA (sym)->attr.dimension;
- codimension = CLASS_DATA (sym)->attr.codimension;
- pointer = CLASS_DATA (sym)->attr.class_pointer;
- allocatable = CLASS_DATA (sym)->attr.allocatable;
- optional |= CLASS_DATA (sym)->attr.optional;
- }
- else
- {
- dimension = attr.dimension;
- codimension = attr.codimension;
- pointer = attr.pointer;
- allocatable = attr.allocatable;
- }
-
- target = attr.target;
- if (pointer || attr.proc_pointer)
- target = 1;
-
- if (ts != NULL && expr->ts.type == BT_UNKNOWN)
- *ts = sym->ts;
-
- has_inquiry_part = false;
- for (ref = expr->ref; ref; ref = ref->next)
- if (ref->type == REF_INQUIRY)
- {
- has_inquiry_part = true;
- optional = false;
- break;
- }
-
- for (ref = expr->ref; ref; ref = ref->next)
- switch (ref->type)
- {
- case REF_ARRAY:
-
- switch (ref->u.ar.type)
- {
- case AR_FULL:
- dimension = 1;
- break;
-
- case AR_SECTION:
- allocatable = pointer = 0;
- dimension = 1;
- optional = false;
- break;
-
- case AR_ELEMENT:
- /* Handle coarrays. */
- if (ref->u.ar.dimen > 0)
- allocatable = pointer = optional = false;
- break;
-
- case AR_UNKNOWN:
- /* For standard conforming code, AR_UNKNOWN should not happen.
- For nonconforming code, gfortran can end up here. Treat it
- as a no-op. */
- break;
- }
-
- break;
-
- case REF_COMPONENT:
- optional = false;
- comp = ref->u.c.component;
- attr = comp->attr;
- if (ts != NULL && !has_inquiry_part)
- {
- *ts = comp->ts;
- /* Don't set the string length if a substring reference
- follows. */
- if (ts->type == BT_CHARACTER
- && ref->next && ref->next->type == REF_SUBSTRING)
- ts->u.cl = NULL;
- }
-
- if (comp->ts.type == BT_CLASS)
- {
- codimension = CLASS_DATA (comp)->attr.codimension;
- pointer = CLASS_DATA (comp)->attr.class_pointer;
- allocatable = CLASS_DATA (comp)->attr.allocatable;
- }
- else
- {
- codimension = comp->attr.codimension;
- if (expr->ts.type == BT_CLASS && strcmp (comp->name, "_data") == 0)
- pointer = comp->attr.class_pointer;
- else
- pointer = comp->attr.pointer;
- allocatable = comp->attr.allocatable;
- }
- if (pointer || attr.proc_pointer)
- target = 1;
-
- break;
-
- case REF_INQUIRY:
- case REF_SUBSTRING:
- allocatable = pointer = optional = false;
- break;
- }
-
- attr.dimension = dimension;
- attr.codimension = codimension;
- attr.pointer = pointer;
- attr.allocatable = allocatable;
- attr.target = target;
- attr.save = sym->attr.save;
- attr.optional = optional;
-
- return attr;
-}
-
-
-/* Return the attribute from a general expression. */
-
-symbol_attribute
-gfc_expr_attr (gfc_expr *e)
-{
- symbol_attribute attr;
-
- switch (e->expr_type)
- {
- case EXPR_VARIABLE:
- attr = gfc_variable_attr (e, NULL);
- break;
-
- case EXPR_FUNCTION:
- gfc_clear_attr (&attr);
-
- if (e->value.function.esym && e->value.function.esym->result)
- {
- gfc_symbol *sym = e->value.function.esym->result;
- attr = sym->attr;
- if (sym->ts.type == BT_CLASS)
- {
- attr.dimension = CLASS_DATA (sym)->attr.dimension;
- attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
- attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
- }
- }
- else if (e->value.function.isym
- && e->value.function.isym->transformational
- && e->ts.type == BT_CLASS)
- attr = CLASS_DATA (e)->attr;
- else if (e->symtree)
- attr = gfc_variable_attr (e, NULL);
-
- /* TODO: NULL() returns pointers. May have to take care of this
- here. */
-
- break;
-
- default:
- gfc_clear_attr (&attr);
- break;
- }
-
- return attr;
-}
-
-
-/* Given an expression, figure out what the ultimate expression
- attribute is. This routine is similar to gfc_variable_attr with
- parts of gfc_expr_attr, but focuses more on the needs of
- coarrays. For coarrays a codimension attribute is kind of
- "infectious" being propagated once set and never cleared.
- The coarray_comp is only set, when the expression refs a coarray
- component. REFS_COMP is set when present to true only, when this EXPR
- refs a (non-_data) component. To check whether EXPR refs an allocatable
- component in a derived type coarray *refs_comp needs to be set and
- coarray_comp has to false. */
-
-static symbol_attribute
-caf_variable_attr (gfc_expr *expr, bool in_allocate, bool *refs_comp)
-{
- int dimension, codimension, pointer, allocatable, target, coarray_comp;
- symbol_attribute attr;
- gfc_ref *ref;
- gfc_symbol *sym;
- gfc_component *comp;
-
- if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
- gfc_internal_error ("gfc_caf_attr(): Expression isn't a variable");
-
- sym = expr->symtree->n.sym;
- gfc_clear_attr (&attr);
-
- if (refs_comp)
- *refs_comp = false;
-
- if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
- {
- dimension = CLASS_DATA (sym)->attr.dimension;
- codimension = CLASS_DATA (sym)->attr.codimension;
- pointer = CLASS_DATA (sym)->attr.class_pointer;
- allocatable = CLASS_DATA (sym)->attr.allocatable;
- attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
- attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp;
- }
- else
- {
- dimension = sym->attr.dimension;
- codimension = sym->attr.codimension;
- pointer = sym->attr.pointer;
- allocatable = sym->attr.allocatable;
- attr.alloc_comp = sym->ts.type == BT_DERIVED
- ? sym->ts.u.derived->attr.alloc_comp : 0;
- attr.pointer_comp = sym->ts.type == BT_DERIVED
- ? sym->ts.u.derived->attr.pointer_comp : 0;
- }
-
- target = coarray_comp = 0;
- if (pointer || attr.proc_pointer)
- target = 1;
-
- for (ref = expr->ref; ref; ref = ref->next)
- switch (ref->type)
- {
- case REF_ARRAY:
-
- switch (ref->u.ar.type)
- {
- case AR_FULL:
- case AR_SECTION:
- dimension = 1;
- break;
-
- case AR_ELEMENT:
- /* Handle coarrays. */
- if (ref->u.ar.dimen > 0 && !in_allocate)
- allocatable = pointer = 0;
- break;
-
- case AR_UNKNOWN:
- /* If any of start, end or stride is not integer, there will
- already have been an error issued. */
- int errors;
- gfc_get_errors (NULL, &errors);
- if (errors == 0)
- gfc_internal_error ("gfc_caf_attr(): Bad array reference");
- }
-
- break;
-
- case REF_COMPONENT:
- comp = ref->u.c.component;
-
- if (comp->ts.type == BT_CLASS)
- {
- /* Set coarray_comp only, when this component introduces the
- coarray. */
- coarray_comp = !codimension && CLASS_DATA (comp)->attr.codimension;
- codimension |= CLASS_DATA (comp)->attr.codimension;
- pointer = CLASS_DATA (comp)->attr.class_pointer;
- allocatable = CLASS_DATA (comp)->attr.allocatable;
- }
- else
- {
- /* Set coarray_comp only, when this component introduces the
- coarray. */
- coarray_comp = !codimension && comp->attr.codimension;
- codimension |= comp->attr.codimension;
- pointer = comp->attr.pointer;
- allocatable = comp->attr.allocatable;
- }
-
- if (refs_comp && strcmp (comp->name, "_data") != 0
- && (ref->next == NULL
- || (ref->next->type == REF_ARRAY && ref->next->next == NULL)))
- *refs_comp = true;
-
- if (pointer || attr.proc_pointer)
- target = 1;
-
- break;
-
- case REF_SUBSTRING:
- case REF_INQUIRY:
- allocatable = pointer = 0;
- break;
- }
-
- attr.dimension = dimension;
- attr.codimension = codimension;
- attr.pointer = pointer;
- attr.allocatable = allocatable;
- attr.target = target;
- attr.save = sym->attr.save;
- attr.coarray_comp = coarray_comp;
-
- return attr;
-}
-
-
-symbol_attribute
-gfc_caf_attr (gfc_expr *e, bool in_allocate, bool *refs_comp)
-{
- symbol_attribute attr;
-
- switch (e->expr_type)
- {
- case EXPR_VARIABLE:
- attr = caf_variable_attr (e, in_allocate, refs_comp);
- break;
-
- case EXPR_FUNCTION:
- gfc_clear_attr (&attr);
-
- if (e->value.function.esym && e->value.function.esym->result)
- {
- gfc_symbol *sym = e->value.function.esym->result;
- attr = sym->attr;
- if (sym->ts.type == BT_CLASS)
- {
- attr.dimension = CLASS_DATA (sym)->attr.dimension;
- attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
- attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
- attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
- attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived
- ->attr.pointer_comp;
- }
- }
- else if (e->symtree)
- attr = caf_variable_attr (e, in_allocate, refs_comp);
- else
- gfc_clear_attr (&attr);
- break;
-
- default:
- gfc_clear_attr (&attr);
- break;
- }
-
- return attr;
-}
-
-
-/* Match a structure constructor. The initial symbol has already been
- seen. */
-
-typedef struct gfc_structure_ctor_component
-{
- char* name;
- gfc_expr* val;
- locus where;
- struct gfc_structure_ctor_component* next;
-}
-gfc_structure_ctor_component;
-
-#define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
-
-static void
-gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
-{
- free (comp->name);
- gfc_free_expr (comp->val);
- free (comp);
-}
-
-
-/* Translate the component list into the actual constructor by sorting it in
- the order required; this also checks along the way that each and every
- component actually has an initializer and handles default initializers
- for components without explicit value given. */
-static bool
-build_actual_constructor (gfc_structure_ctor_component **comp_head,
- gfc_constructor_base *ctor_head, gfc_symbol *sym)
-{
- gfc_structure_ctor_component *comp_iter;
- gfc_component *comp;
-
- for (comp = sym->components; comp; comp = comp->next)
- {
- gfc_structure_ctor_component **next_ptr;
- gfc_expr *value = NULL;
-
- /* Try to find the initializer for the current component by name. */
- next_ptr = comp_head;
- for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
- {
- if (!strcmp (comp_iter->name, comp->name))
- break;
- next_ptr = &comp_iter->next;
- }
-
- /* If an extension, try building the parent derived type by building
- a value expression for the parent derived type and calling self. */
- if (!comp_iter && comp == sym->components && sym->attr.extension)
- {
- value = gfc_get_structure_constructor_expr (comp->ts.type,
- comp->ts.kind,
- &gfc_current_locus);
- value->ts = comp->ts;
-
- if (!build_actual_constructor (comp_head,
- &value->value.constructor,
- comp->ts.u.derived))
- {
- gfc_free_expr (value);
- return false;
- }
-
- gfc_constructor_append_expr (ctor_head, value, NULL);
- continue;
- }
-
- /* If it was not found, apply NULL expression to set the component as
- unallocated. Then try the default initializer if there's any;
- otherwise, it's an error unless this is a deferred parameter. */
- if (!comp_iter)
- {
- /* F2018 7.5.10: If an allocatable component has no corresponding
- component-data-source, then that component has an allocation
- status of unallocated.... */
- if (comp->attr.allocatable
- || (comp->ts.type == BT_CLASS
- && CLASS_DATA (comp)->attr.allocatable))
- {
- if (!gfc_notify_std (GFC_STD_F2008, "No initializer for "
- "allocatable component %qs given in the "
- "structure constructor at %C", comp->name))
- return false;
- value = gfc_get_null_expr (&gfc_current_locus);
- }
- /* ....(Preceeding sentence) If a component with default
- initialization has no corresponding component-data-source, then
- the default initialization is applied to that component. */
- else if (comp->initializer)
- {
- if (!gfc_notify_std (GFC_STD_F2003, "Structure constructor "
- "with missing optional arguments at %C"))
- return false;
- value = gfc_copy_expr (comp->initializer);
- }
- /* Do not trap components such as the string length for deferred
- length character components. */
- else if (!comp->attr.artificial)
- {
- gfc_error ("No initializer for component %qs given in the"
- " structure constructor at %C", comp->name);
- return false;
- }
- }
- else
- value = comp_iter->val;
-
- /* Add the value to the constructor chain built. */
- gfc_constructor_append_expr (ctor_head, value, NULL);
-
- /* Remove the entry from the component list. We don't want the expression
- value to be free'd, so set it to NULL. */
- if (comp_iter)
- {
- *next_ptr = comp_iter->next;
- comp_iter->val = NULL;
- gfc_free_structure_ctor_component (comp_iter);
- }
- }
- return true;
-}
-
-
-bool
-gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **cexpr,
- gfc_actual_arglist **arglist,
- bool parent)
-{
- gfc_actual_arglist *actual;
- gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
- gfc_constructor_base ctor_head = NULL;
- gfc_component *comp; /* Is set NULL when named component is first seen */
- const char* last_name = NULL;
- locus old_locus;
- gfc_expr *expr;
-
- expr = parent ? *cexpr : e;
- old_locus = gfc_current_locus;
- if (parent)
- ; /* gfc_current_locus = *arglist->expr ? ->where;*/
- else
- gfc_current_locus = expr->where;
-
- comp_tail = comp_head = NULL;
-
- if (!parent && sym->attr.abstract)
- {
- gfc_error ("Cannot construct ABSTRACT type %qs at %L",
- sym->name, &expr->where);
- goto cleanup;
- }
-
- comp = sym->components;
- actual = parent ? *arglist : expr->value.function.actual;
- for ( ; actual; )
- {
- gfc_component *this_comp = NULL;
-
- if (!comp_head)
- comp_tail = comp_head = gfc_get_structure_ctor_component ();
- else
- {
- comp_tail->next = gfc_get_structure_ctor_component ();
- comp_tail = comp_tail->next;
- }
- if (actual->name)
- {
- if (!gfc_notify_std (GFC_STD_F2003, "Structure"
- " constructor with named arguments at %C"))
- goto cleanup;
-
- comp_tail->name = xstrdup (actual->name);
- last_name = comp_tail->name;
- comp = NULL;
- }
- else
- {
- /* Components without name are not allowed after the first named
- component initializer! */
- if (!comp || comp->attr.artificial)
- {
- if (last_name)
- gfc_error ("Component initializer without name after component"
- " named %s at %L", last_name,
- actual->expr ? &actual->expr->where
- : &gfc_current_locus);
- else
- gfc_error ("Too many components in structure constructor at "
- "%L", actual->expr ? &actual->expr->where
- : &gfc_current_locus);
- goto cleanup;
- }
-
- comp_tail->name = xstrdup (comp->name);
- }
-
- /* Find the current component in the structure definition and check
- its access is not private. */
- if (comp)
- this_comp = gfc_find_component (sym, comp->name, false, false, NULL);
- else
- {
- this_comp = gfc_find_component (sym, (const char *)comp_tail->name,
- false, false, NULL);
- comp = NULL; /* Reset needed! */
- }
-
- /* Here we can check if a component name is given which does not
- correspond to any component of the defined structure. */
- if (!this_comp)
- goto cleanup;
-
- /* For a constant string constructor, make sure the length is
- correct; truncate of fill with blanks if needed. */
- if (this_comp->ts.type == BT_CHARACTER && !this_comp->attr.allocatable
- && this_comp->ts.u.cl && this_comp->ts.u.cl->length
- && this_comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
- && actual->expr->ts.type == BT_CHARACTER
- && actual->expr->expr_type == EXPR_CONSTANT)
- {
- ptrdiff_t c, e1;
- c = gfc_mpz_get_hwi (this_comp->ts.u.cl->length->value.integer);
- e1 = actual->expr->value.character.length;
-
- if (c != e1)
- {
- ptrdiff_t i, to;
- gfc_char_t *dest;
- dest = gfc_get_wide_string (c + 1);
-
- to = e1 < c ? e1 : c;
- for (i = 0; i < to; i++)
- dest[i] = actual->expr->value.character.string[i];
-
- for (i = e1; i < c; i++)
- dest[i] = ' ';
-
- dest[c] = '\0';
- free (actual->expr->value.character.string);
-
- actual->expr->value.character.length = c;
- actual->expr->value.character.string = dest;
-
- if (warn_line_truncation && c < e1)
- gfc_warning_now (OPT_Wcharacter_truncation,
- "CHARACTER expression will be truncated "
- "in constructor (%ld/%ld) at %L", (long int) c,
- (long int) e1, &actual->expr->where);
- }
- }
-
- comp_tail->val = actual->expr;
- if (actual->expr != NULL)
- comp_tail->where = actual->expr->where;
- actual->expr = NULL;
-
- /* Check if this component is already given a value. */
- for (comp_iter = comp_head; comp_iter != comp_tail;
- comp_iter = comp_iter->next)
- {
- gcc_assert (comp_iter);
- if (!strcmp (comp_iter->name, comp_tail->name))
- {
- gfc_error ("Component %qs is initialized twice in the structure"
- " constructor at %L", comp_tail->name,
- comp_tail->val ? &comp_tail->where
- : &gfc_current_locus);
- goto cleanup;
- }
- }
-
- /* F2008, R457/C725, for PURE C1283. */
- if (this_comp->attr.pointer && comp_tail->val
- && gfc_is_coindexed (comp_tail->val))
- {
- gfc_error ("Coindexed expression to pointer component %qs in "
- "structure constructor at %L", comp_tail->name,
- &comp_tail->where);
- goto cleanup;
- }
-
- /* If not explicitly a parent constructor, gather up the components
- and build one. */
- if (comp && comp == sym->components
- && sym->attr.extension
- && comp_tail->val
- && (!gfc_bt_struct (comp_tail->val->ts.type)
- ||
- comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
- {
- bool m;
- gfc_actual_arglist *arg_null = NULL;
-
- actual->expr = comp_tail->val;
- comp_tail->val = NULL;
-
- m = gfc_convert_to_structure_constructor (NULL,
- comp->ts.u.derived, &comp_tail->val,
- comp->ts.u.derived->attr.zero_comp
- ? &arg_null : &actual, true);
- if (!m)
- goto cleanup;
-
- if (comp->ts.u.derived->attr.zero_comp)
- {
- comp = comp->next;
- continue;
- }
- }
-
- if (comp)
- comp = comp->next;
- if (parent && !comp)
- break;
-
- if (actual)
- actual = actual->next;
- }
-
- if (!build_actual_constructor (&comp_head, &ctor_head, sym))
- goto cleanup;
-
- /* No component should be left, as this should have caused an error in the
- loop constructing the component-list (name that does not correspond to any
- component in the structure definition). */
- if (comp_head && sym->attr.extension)
- {
- for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
- {
- gfc_error ("component %qs at %L has already been set by a "
- "parent derived type constructor", comp_iter->name,
- &comp_iter->where);
- }
- goto cleanup;
- }
- else
- gcc_assert (!comp_head);
-
- if (parent)
- {
- expr = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &gfc_current_locus);
- expr->ts.u.derived = sym;
- expr->value.constructor = ctor_head;
- *cexpr = expr;
- }
- else
- {
- expr->ts.u.derived = sym;
- expr->ts.kind = 0;
- expr->ts.type = BT_DERIVED;
- expr->value.constructor = ctor_head;
- expr->expr_type = EXPR_STRUCTURE;
- }
-
- gfc_current_locus = old_locus;
- if (parent)
- *arglist = actual;
- return true;
-
- cleanup:
- gfc_current_locus = old_locus;
-
- for (comp_iter = comp_head; comp_iter; )
- {
- gfc_structure_ctor_component *next = comp_iter->next;
- gfc_free_structure_ctor_component (comp_iter);
- comp_iter = next;
- }
- gfc_constructor_free (ctor_head);
-
- return false;
-}
-
-
-match
-gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
-{
- match m;
- gfc_expr *e;
- gfc_symtree *symtree;
- bool t = true;
-
- gfc_get_ha_sym_tree (sym->name, &symtree);
-
- e = gfc_get_expr ();
- e->symtree = symtree;
- e->expr_type = EXPR_FUNCTION;
- e->where = gfc_current_locus;
-
- gcc_assert (gfc_fl_struct (sym->attr.flavor)
- && symtree->n.sym->attr.flavor == FL_PROCEDURE);
- e->value.function.esym = sym;
- e->symtree->n.sym->attr.generic = 1;
-
- m = gfc_match_actual_arglist (0, &e->value.function.actual);
- if (m != MATCH_YES)
- {
- gfc_free_expr (e);
- return m;
- }
-
- if (!gfc_convert_to_structure_constructor (e, sym, NULL, NULL, false))
- {
- gfc_free_expr (e);
- return MATCH_ERROR;
- }
-
- /* If a structure constructor is in a DATA statement, then each entity
- in the structure constructor must be a constant. Try to reduce the
- expression here. */
- if (gfc_in_match_data ())
- t = gfc_reduce_init_expr (e);
-
- if (t)
- {
- *result = e;
- return MATCH_YES;
- }
- else
- {
- gfc_free_expr (e);
- return MATCH_ERROR;
- }
-}
-
-
-/* If the symbol is an implicit do loop index and implicitly typed,
- it should not be host associated. Provide a symtree from the
- current namespace. */
-static match
-check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
-{
- if ((*sym)->attr.flavor == FL_VARIABLE
- && (*sym)->ns != gfc_current_ns
- && (*sym)->attr.implied_index
- && (*sym)->attr.implicit_type
- && !(*sym)->attr.use_assoc)
- {
- int i;
- i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
- if (i)
- return MATCH_ERROR;
- *sym = (*st)->n.sym;
- }
- return MATCH_YES;
-}
-
-
-/* Procedure pointer as function result: Replace the function symbol by the
- auto-generated hidden result variable named "ppr@". */
-
-static bool
-replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
-{
- /* Check for procedure pointer result variable. */
- if ((*sym)->attr.function && !(*sym)->attr.external
- && (*sym)->result && (*sym)->result != *sym
- && (*sym)->result->attr.proc_pointer
- && (*sym) == gfc_current_ns->proc_name
- && (*sym) == (*sym)->result->ns->proc_name
- && strcmp ("ppr@", (*sym)->result->name) == 0)
- {
- /* Automatic replacement with "hidden" result variable. */
- (*sym)->result->attr.referenced = (*sym)->attr.referenced;
- *sym = (*sym)->result;
- *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
- return true;
- }
- return false;
-}
-
-
-/* Matches a variable name followed by anything that might follow it--
- array reference, argument list of a function, etc. */
-
-match
-gfc_match_rvalue (gfc_expr **result)
-{
- gfc_actual_arglist *actual_arglist;
- char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
- gfc_state_data *st;
- gfc_symbol *sym;
- gfc_symtree *symtree;
- locus where, old_loc;
- gfc_expr *e;
- match m, m2;
- int i;
- gfc_typespec *ts;
- bool implicit_char;
- gfc_ref *ref;
-
- m = gfc_match ("%%loc");
- if (m == MATCH_YES)
- {
- if (!gfc_notify_std (GFC_STD_LEGACY, "%%LOC() as an rvalue at %C"))
- return MATCH_ERROR;
- strncpy (name, "loc", 4);
- }
-
- else
- {
- m = gfc_match_name (name);
- if (m != MATCH_YES)
- return m;
- }
-
- /* Check if the symbol exists. */
- if (gfc_find_sym_tree (name, NULL, 1, &symtree))
- return MATCH_ERROR;
-
- /* If the symbol doesn't exist, create it unless the name matches a FL_STRUCT
- type. For derived types we create a generic symbol which links to the
- derived type symbol; STRUCTUREs are simpler and must not conflict with
- variables. */
- if (!symtree)
- if (gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree))
- return MATCH_ERROR;
- if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT)
- {
- if (gfc_find_state (COMP_INTERFACE)
- && !gfc_current_ns->has_import_set)
- i = gfc_get_sym_tree (name, NULL, &symtree, false);
- else
- i = gfc_get_ha_sym_tree (name, &symtree);
- if (i)
- return MATCH_ERROR;
- }
-
-
- sym = symtree->n.sym;
- e = NULL;
- where = gfc_current_locus;
-
- replace_hidden_procptr_result (&sym, &symtree);
-
- /* If this is an implicit do loop index and implicitly typed,
- it should not be host associated. */
- m = check_for_implicit_index (&symtree, &sym);
- if (m != MATCH_YES)
- return m;
-
- gfc_set_sym_referenced (sym);
- sym->attr.implied_index = 0;
-
- if (sym->attr.function && sym->result == sym)
- {
- /* See if this is a directly recursive function call. */
- gfc_gobble_whitespace ();
- if (sym->attr.recursive
- && gfc_peek_ascii_char () == '('
- && gfc_current_ns->proc_name == sym
- && !sym->attr.dimension)
- {
- gfc_error ("%qs at %C is the name of a recursive function "
- "and so refers to the result variable. Use an "
- "explicit RESULT variable for direct recursion "
- "(12.5.2.1)", sym->name);
- return MATCH_ERROR;
- }
-
- if (gfc_is_function_return_value (sym, gfc_current_ns))
- goto variable;
-
- if (sym->attr.entry
- && (sym->ns == gfc_current_ns
- || sym->ns == gfc_current_ns->parent))
- {
- gfc_entry_list *el = NULL;
-
- for (el = sym->ns->entries; el; el = el->next)
- if (sym == el->sym)
- goto variable;
- }
- }
-
- if (gfc_matching_procptr_assignment)
- {
- /* It can be a procedure or a derived-type procedure or a not-yet-known
- type. */
- if (sym->attr.flavor != FL_UNKNOWN
- && sym->attr.flavor != FL_PROCEDURE
- && sym->attr.flavor != FL_PARAMETER
- && sym->attr.flavor != FL_VARIABLE)
- {
- gfc_error ("Symbol at %C is not appropriate for an expression");
- return MATCH_ERROR;
- }
- goto procptr0;
- }
-
- if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
- goto function0;
-
- if (sym->attr.generic)
- goto generic_function;
-
- switch (sym->attr.flavor)
- {
- case FL_VARIABLE:
- variable:
- e = gfc_get_expr ();
-
- e->expr_type = EXPR_VARIABLE;
- e->symtree = symtree;
-
- m = gfc_match_varspec (e, 0, false, true);
- break;
-
- case FL_PARAMETER:
- /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
- end up here. Unfortunately, sym->value->expr_type is set to
- EXPR_CONSTANT, and so the if () branch would be followed without
- the !sym->as check. */
- if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
- e = gfc_copy_expr (sym->value);
- else
- {
- e = gfc_get_expr ();
- e->expr_type = EXPR_VARIABLE;
- }
-
- e->symtree = symtree;
- m = gfc_match_varspec (e, 0, false, true);
-
- if (sym->ts.is_c_interop || sym->ts.is_iso_c)
- break;
-
- /* Variable array references to derived type parameters cause
- all sorts of headaches in simplification. Treating such
- expressions as variable works just fine for all array
- references. */
- if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
- {
- for (ref = e->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY)
- break;
-
- if (ref == NULL || ref->u.ar.type == AR_FULL)
- break;
-
- ref = e->ref;
- e->ref = NULL;
- gfc_free_expr (e);
- e = gfc_get_expr ();
- e->expr_type = EXPR_VARIABLE;
- e->symtree = symtree;
- e->ref = ref;
- }
-
- break;
-
- case FL_STRUCT:
- case FL_DERIVED:
- sym = gfc_use_derived (sym);
- if (sym == NULL)
- m = MATCH_ERROR;
- else
- goto generic_function;
- break;
-
- /* If we're here, then the name is known to be the name of a
- procedure, yet it is not sure to be the name of a function. */
- case FL_PROCEDURE:
-
- /* Procedure Pointer Assignments. */
- procptr0:
- if (gfc_matching_procptr_assignment)
- {
- gfc_gobble_whitespace ();
- if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
- /* Parse functions returning a procptr. */
- goto function0;
-
- e = gfc_get_expr ();
- e->expr_type = EXPR_VARIABLE;
- e->symtree = symtree;
- m = gfc_match_varspec (e, 0, false, true);
- if (!e->ref && sym->attr.flavor == FL_UNKNOWN
- && sym->ts.type == BT_UNKNOWN
- && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
- {
- m = MATCH_ERROR;
- break;
- }
- break;
- }
-
- if (sym->attr.subroutine)
- {
- gfc_error ("Unexpected use of subroutine name %qs at %C",
- sym->name);
- m = MATCH_ERROR;
- break;
- }
-
- /* At this point, the name has to be a non-statement function.
- If the name is the same as the current function being
- compiled, then we have a variable reference (to the function
- result) if the name is non-recursive. */
-
- st = gfc_enclosing_unit (NULL);
-
- if (st != NULL
- && st->state == COMP_FUNCTION
- && st->sym == sym
- && !sym->attr.recursive)
- {
- e = gfc_get_expr ();
- e->symtree = symtree;
- e->expr_type = EXPR_VARIABLE;
-
- m = gfc_match_varspec (e, 0, false, true);
- break;
- }
-
- /* Match a function reference. */
- function0:
- m = gfc_match_actual_arglist (0, &actual_arglist);
- if (m == MATCH_NO)
- {
- if (sym->attr.proc == PROC_ST_FUNCTION)
- gfc_error ("Statement function %qs requires argument list at %C",
- sym->name);
- else
- gfc_error ("Function %qs requires an argument list at %C",
- sym->name);
-
- m = MATCH_ERROR;
- break;
- }
-
- if (m != MATCH_YES)
- {
- m = MATCH_ERROR;
- break;
- }
-
- gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
- sym = symtree->n.sym;
-
- replace_hidden_procptr_result (&sym, &symtree);
-
- e = gfc_get_expr ();
- e->symtree = symtree;
- e->expr_type = EXPR_FUNCTION;
- e->value.function.actual = actual_arglist;
- e->where = gfc_current_locus;
-
- if (sym->ts.type == BT_CLASS && sym->attr.class_ok
- && CLASS_DATA (sym)->as)
- e->rank = CLASS_DATA (sym)->as->rank;
- else if (sym->as != NULL)
- e->rank = sym->as->rank;
-
- if (!sym->attr.function
- && !gfc_add_function (&sym->attr, sym->name, NULL))
- {
- m = MATCH_ERROR;
- break;
- }
-
- /* Check here for the existence of at least one argument for the
- iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
- argument(s) given will be checked in gfc_iso_c_func_interface,
- during resolution of the function call. */
- if (sym->attr.is_iso_c == 1
- && (sym->from_intmod == INTMOD_ISO_C_BINDING
- && (sym->intmod_sym_id == ISOCBINDING_LOC
- || sym->intmod_sym_id == ISOCBINDING_FUNLOC
- || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
- {
- /* make sure we were given a param */
- if (actual_arglist == NULL)
- {
- gfc_error ("Missing argument to %qs at %C", sym->name);
- m = MATCH_ERROR;
- break;
- }
- }
-
- if (sym->result == NULL)
- sym->result = sym;
-
- gfc_gobble_whitespace ();
- /* F08:C612. */
- if (gfc_peek_ascii_char() == '%')
- {
- gfc_error ("The leftmost part-ref in a data-ref cannot be a "
- "function reference at %C");
- m = MATCH_ERROR;
- break;
- }
-
- m = MATCH_YES;
- break;
-
- case FL_UNKNOWN:
-
- /* Special case for derived type variables that get their types
- via an IMPLICIT statement. This can't wait for the
- resolution phase. */
-
- old_loc = gfc_current_locus;
- if (gfc_match_member_sep (sym) == MATCH_YES
- && sym->ts.type == BT_UNKNOWN
- && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
- gfc_set_default_type (sym, 0, sym->ns);
- gfc_current_locus = old_loc;
-
- /* If the symbol has a (co)dimension attribute, the expression is a
- variable. */
-
- if (sym->attr.dimension || sym->attr.codimension)
- {
- if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
- {
- m = MATCH_ERROR;
- break;
- }
-
- e = gfc_get_expr ();
- e->symtree = symtree;
- e->expr_type = EXPR_VARIABLE;
- m = gfc_match_varspec (e, 0, false, true);
- break;
- }
-
- if (sym->ts.type == BT_CLASS && sym->attr.class_ok
- && (CLASS_DATA (sym)->attr.dimension
- || CLASS_DATA (sym)->attr.codimension))
- {
- if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
- {
- m = MATCH_ERROR;
- break;
- }
-
- e = gfc_get_expr ();
- e->symtree = symtree;
- e->expr_type = EXPR_VARIABLE;
- m = gfc_match_varspec (e, 0, false, true);
- break;
- }
-
- /* Name is not an array, so we peek to see if a '(' implies a
- function call or a substring reference. Otherwise the
- variable is just a scalar. */
-
- gfc_gobble_whitespace ();
- if (gfc_peek_ascii_char () != '(')
- {
- /* Assume a scalar variable */
- e = gfc_get_expr ();
- e->symtree = symtree;
- e->expr_type = EXPR_VARIABLE;
-
- if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
- {
- m = MATCH_ERROR;
- break;
- }
-
- /*FIXME:??? gfc_match_varspec does set this for us: */
- e->ts = sym->ts;
- m = gfc_match_varspec (e, 0, false, true);
- break;
- }
-
- /* See if this is a function reference with a keyword argument
- as first argument. We do this because otherwise a spurious
- symbol would end up in the symbol table. */
-
- old_loc = gfc_current_locus;
- m2 = gfc_match (" ( %n =", argname);
- gfc_current_locus = old_loc;
-
- e = gfc_get_expr ();
- e->symtree = symtree;
-
- if (m2 != MATCH_YES)
- {
- /* Try to figure out whether we're dealing with a character type.
- We're peeking ahead here, because we don't want to call
- match_substring if we're dealing with an implicitly typed
- non-character variable. */
- implicit_char = false;
- if (sym->ts.type == BT_UNKNOWN)
- {
- ts = gfc_get_default_type (sym->name, NULL);
- if (ts->type == BT_CHARACTER)
- implicit_char = true;
- }
-
- /* See if this could possibly be a substring reference of a name
- that we're not sure is a variable yet. */
-
- if ((implicit_char || sym->ts.type == BT_CHARACTER)
- && match_substring (sym->ts.u.cl, 0, &e->ref, false) == MATCH_YES)
- {
-
- e->expr_type = EXPR_VARIABLE;
-
- if (sym->attr.flavor != FL_VARIABLE
- && !gfc_add_flavor (&sym->attr, FL_VARIABLE,
- sym->name, NULL))
- {
- m = MATCH_ERROR;
- break;
- }
-
- if (sym->ts.type == BT_UNKNOWN
- && !gfc_set_default_type (sym, 1, NULL))
- {
- m = MATCH_ERROR;
- break;
- }
-
- e->ts = sym->ts;
- if (e->ref)
- e->ts.u.cl = NULL;
- m = MATCH_YES;
- break;
- }
- }
-
- /* Give up, assume we have a function. */
-
- gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
- sym = symtree->n.sym;
- e->expr_type = EXPR_FUNCTION;
-
- if (!sym->attr.function
- && !gfc_add_function (&sym->attr, sym->name, NULL))
- {
- m = MATCH_ERROR;
- break;
- }
-
- sym->result = sym;
-
- m = gfc_match_actual_arglist (0, &e->value.function.actual);
- if (m == MATCH_NO)
- gfc_error ("Missing argument list in function %qs at %C", sym->name);
-
- if (m != MATCH_YES)
- {
- m = MATCH_ERROR;
- break;
- }
-
- /* If our new function returns a character, array or structure
- type, it might have subsequent references. */
-
- m = gfc_match_varspec (e, 0, false, true);
- if (m == MATCH_NO)
- m = MATCH_YES;
-
- break;
-
- generic_function:
- /* Look for symbol first; if not found, look for STRUCTURE type symbol
- specially. Creates a generic symbol for derived types. */
- gfc_find_sym_tree (name, NULL, 1, &symtree);
- if (!symtree)
- gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree);
- if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT)
- gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
-
- e = gfc_get_expr ();
- e->symtree = symtree;
- e->expr_type = EXPR_FUNCTION;
-
- if (gfc_fl_struct (sym->attr.flavor))
- {
- e->value.function.esym = sym;
- e->symtree->n.sym->attr.generic = 1;
- }
-
- m = gfc_match_actual_arglist (0, &e->value.function.actual);
- break;
-
- case FL_NAMELIST:
- m = MATCH_ERROR;
- break;
-
- default:
- gfc_error ("Symbol at %C is not appropriate for an expression");
- return MATCH_ERROR;
- }
-
- if (m == MATCH_YES)
- {
- e->where = where;
- *result = e;
- }
- else
- gfc_free_expr (e);
-
- return m;
-}
-
-
-/* Match a variable, i.e. something that can be assigned to. This
- starts as a symbol, can be a structure component or an array
- reference. It can be a function if the function doesn't have a
- separate RESULT variable. If the symbol has not been previously
- seen, we assume it is a variable.
-
- This function is called by two interface functions:
- gfc_match_variable, which has host_flag = 1, and
- gfc_match_equiv_variable, with host_flag = 0, to restrict the
- match of the symbol to the local scope. */
-
-static match
-match_variable (gfc_expr **result, int equiv_flag, int host_flag)
-{
- gfc_symbol *sym, *dt_sym;
- gfc_symtree *st;
- gfc_expr *expr;
- locus where, old_loc;
- match m;
-
- /* Since nothing has any business being an lvalue in a module
- specification block, an interface block or a contains section,
- we force the changed_symbols mechanism to work by setting
- host_flag to 0. This prevents valid symbols that have the name
- of keywords, such as 'end', being turned into variables by
- failed matching to assignments for, e.g., END INTERFACE. */
- if (gfc_current_state () == COMP_MODULE
- || gfc_current_state () == COMP_SUBMODULE
- || gfc_current_state () == COMP_INTERFACE
- || gfc_current_state () == COMP_CONTAINS)
- host_flag = 0;
-
- where = gfc_current_locus;
- m = gfc_match_sym_tree (&st, host_flag);
- if (m != MATCH_YES)
- return m;
-
- sym = st->n.sym;
-
- /* If this is an implicit do loop index and implicitly typed,
- it should not be host associated. */
- m = check_for_implicit_index (&st, &sym);
- if (m != MATCH_YES)
- return m;
-
- sym->attr.implied_index = 0;
-
- gfc_set_sym_referenced (sym);
-
- /* STRUCTUREs may share names with variables, but derived types may not. */
- if (sym->attr.flavor == FL_PROCEDURE && sym->generic
- && (dt_sym = gfc_find_dt_in_generic (sym)))
- {
- if (dt_sym->attr.flavor == FL_DERIVED)
- gfc_error ("Derived type %qs cannot be used as a variable at %C",
- sym->name);
- return MATCH_ERROR;
- }
-
- switch (sym->attr.flavor)
- {
- case FL_VARIABLE:
- /* Everything is alright. */
- break;
-
- case FL_UNKNOWN:
- {
- sym_flavor flavor = FL_UNKNOWN;
-
- gfc_gobble_whitespace ();
-
- if (sym->attr.external || sym->attr.procedure
- || sym->attr.function || sym->attr.subroutine)
- flavor = FL_PROCEDURE;
-
- /* If it is not a procedure, is not typed and is host associated,
- we cannot give it a flavor yet. */
- else if (sym->ns == gfc_current_ns->parent
- && sym->ts.type == BT_UNKNOWN)
- break;
-
- /* These are definitive indicators that this is a variable. */
- else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
- || sym->attr.pointer || sym->as != NULL)
- flavor = FL_VARIABLE;
-
- if (flavor != FL_UNKNOWN
- && !gfc_add_flavor (&sym->attr, flavor, sym->name, NULL))
- return MATCH_ERROR;
- }
- break;
-
- case FL_PARAMETER:
- if (equiv_flag)
- {
- gfc_error ("Named constant at %C in an EQUIVALENCE");
- return MATCH_ERROR;
- }
- /* Otherwise this is checked for and an error given in the
- variable definition context checks. */
- break;
-
- case FL_PROCEDURE:
- /* Check for a nonrecursive function result variable. */
- if (sym->attr.function
- && !sym->attr.external
- && sym->result == sym
- && (gfc_is_function_return_value (sym, gfc_current_ns)
- || (sym->attr.entry
- && sym->ns == gfc_current_ns)
- || (sym->attr.entry
- && sym->ns == gfc_current_ns->parent)))
- {
- /* If a function result is a derived type, then the derived
- type may still have to be resolved. */
-
- if (sym->ts.type == BT_DERIVED
- && gfc_use_derived (sym->ts.u.derived) == NULL)
- return MATCH_ERROR;
- break;
- }
-
- if (sym->attr.proc_pointer
- || replace_hidden_procptr_result (&sym, &st))
- break;
-
- /* Fall through to error */
- gcc_fallthrough ();
-
- default:
- gfc_error ("%qs at %C is not a variable", sym->name);
- return MATCH_ERROR;
- }
-
- /* Special case for derived type variables that get their types
- via an IMPLICIT statement. This can't wait for the
- resolution phase. */
-
- {
- gfc_namespace * implicit_ns;
-
- if (gfc_current_ns->proc_name == sym)
- implicit_ns = gfc_current_ns;
- else
- implicit_ns = sym->ns;
-
- old_loc = gfc_current_locus;
- if (gfc_match_member_sep (sym) == MATCH_YES
- && sym->ts.type == BT_UNKNOWN
- && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
- gfc_set_default_type (sym, 0, implicit_ns);
- gfc_current_locus = old_loc;
- }
-
- expr = gfc_get_expr ();
-
- expr->expr_type = EXPR_VARIABLE;
- expr->symtree = st;
- expr->ts = sym->ts;
- expr->where = where;
-
- /* Now see if we have to do more. */
- m = gfc_match_varspec (expr, equiv_flag, false, false);
- if (m != MATCH_YES)
- {
- gfc_free_expr (expr);
- return m;
- }
-
- *result = expr;
- return MATCH_YES;
-}
-
-
-match
-gfc_match_variable (gfc_expr **result, int equiv_flag)
-{
- return match_variable (result, equiv_flag, 1);
-}
-
-
-match
-gfc_match_equiv_variable (gfc_expr **result)
-{
- return match_variable (result, 1, 0);
-}
-
generated by cgit v1.1 at 2025-05-22 04:03:54 +0000