From 5c69acb32329d49e58c26fa41ae74229a52b9106 Mon Sep 17 00:00:00 2001 From: Martin Liska Date: Fri, 14 Jan 2022 16:56:44 +0100 Subject: 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. --- gcc/fortran/primary.cc | 4175 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 4175 insertions(+) create mode 100644 gcc/fortran/primary.cc (limited to 'gcc/fortran/primary.cc') diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc new file mode 100644 index 0000000..3f01f67 --- /dev/null +++ b/gcc/fortran/primary.cc @@ -0,0 +1,4175 @@ +/* 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 +. */ + +#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 % 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 % 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 % 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 % 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); +} + -- cgit v1.1