aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/expr.c
diff options
context:
space:
mode:
authorMartin Liska <mliska@suse.cz>2022-01-14 16:56:44 +0100
committerMartin Liska <mliska@suse.cz>2022-01-17 22:12:04 +0100
commit5c69acb32329d49e58c26fa41ae74229a52b9106 (patch)
treeddb05f9d73afb6f998457d2ac4b720e3b3b60483 /gcc/fortran/expr.c
parent490e23032baaece71f2ec09fa1805064b150fbc2 (diff)
downloadgcc-5c69acb32329d49e58c26fa41ae74229a52b9106.zip
gcc-5c69acb32329d49e58c26fa41ae74229a52b9106.tar.gz
gcc-5c69acb32329d49e58c26fa41ae74229a52b9106.tar.bz2
Rename .c files to .cc files.
gcc/ada/ChangeLog: * adadecode.c: Moved to... * adadecode.cc: ...here. * affinity.c: Moved to... * affinity.cc: ...here. * argv-lynxos178-raven-cert.c: Moved to... * argv-lynxos178-raven-cert.cc: ...here. * argv.c: Moved to... * argv.cc: ...here. * aux-io.c: Moved to... * aux-io.cc: ...here. * cio.c: Moved to... * cio.cc: ...here. * cstreams.c: Moved to... * cstreams.cc: ...here. * env.c: Moved to... * env.cc: ...here. * exit.c: Moved to... * exit.cc: ...here. * expect.c: Moved to... * expect.cc: ...here. * final.c: Moved to... * final.cc: ...here. * gcc-interface/cuintp.c: Moved to... * gcc-interface/cuintp.cc: ...here. * gcc-interface/decl.c: Moved to... * gcc-interface/decl.cc: ...here. * gcc-interface/misc.c: Moved to... * gcc-interface/misc.cc: ...here. * gcc-interface/targtyps.c: Moved to... * gcc-interface/targtyps.cc: ...here. * gcc-interface/trans.c: Moved to... * gcc-interface/trans.cc: ...here. * gcc-interface/utils.c: Moved to... * gcc-interface/utils.cc: ...here. * gcc-interface/utils2.c: Moved to... * gcc-interface/utils2.cc: ...here. * init.c: Moved to... * init.cc: ...here. * initialize.c: Moved to... * initialize.cc: ...here. * libgnarl/thread.c: Moved to... * libgnarl/thread.cc: ...here. * link.c: Moved to... * link.cc: ...here. * locales.c: Moved to... * locales.cc: ...here. * mkdir.c: Moved to... * mkdir.cc: ...here. * raise.c: Moved to... * raise.cc: ...here. * rtfinal.c: Moved to... * rtfinal.cc: ...here. * rtinit.c: Moved to... * rtinit.cc: ...here. * seh_init.c: Moved to... * seh_init.cc: ...here. * sigtramp-armdroid.c: Moved to... * sigtramp-armdroid.cc: ...here. * sigtramp-ios.c: Moved to... * sigtramp-ios.cc: ...here. * sigtramp-qnx.c: Moved to... * sigtramp-qnx.cc: ...here. * sigtramp-vxworks.c: Moved to... * sigtramp-vxworks.cc: ...here. * socket.c: Moved to... * socket.cc: ...here. * tracebak.c: Moved to... * tracebak.cc: ...here. * version.c: Moved to... * version.cc: ...here. * vx_stack_info.c: Moved to... * vx_stack_info.cc: ...here. gcc/ChangeLog: * adjust-alignment.c: Moved to... * adjust-alignment.cc: ...here. * alias.c: Moved to... * alias.cc: ...here. * alloc-pool.c: Moved to... * alloc-pool.cc: ...here. * asan.c: Moved to... * asan.cc: ...here. * attribs.c: Moved to... * attribs.cc: ...here. * auto-inc-dec.c: Moved to... * auto-inc-dec.cc: ...here. * auto-profile.c: Moved to... * auto-profile.cc: ...here. * bb-reorder.c: Moved to... * bb-reorder.cc: ...here. * bitmap.c: Moved to... * bitmap.cc: ...here. * btfout.c: Moved to... * btfout.cc: ...here. * builtins.c: Moved to... * builtins.cc: ...here. * caller-save.c: Moved to... * caller-save.cc: ...here. * calls.c: Moved to... * calls.cc: ...here. * ccmp.c: Moved to... * ccmp.cc: ...here. * cfg.c: Moved to... * cfg.cc: ...here. * cfganal.c: Moved to... * cfganal.cc: ...here. * cfgbuild.c: Moved to... * cfgbuild.cc: ...here. * cfgcleanup.c: Moved to... * cfgcleanup.cc: ...here. * cfgexpand.c: Moved to... * cfgexpand.cc: ...here. * cfghooks.c: Moved to... * cfghooks.cc: ...here. * cfgloop.c: Moved to... * cfgloop.cc: ...here. * cfgloopanal.c: Moved to... * cfgloopanal.cc: ...here. * cfgloopmanip.c: Moved to... * cfgloopmanip.cc: ...here. * cfgrtl.c: Moved to... * cfgrtl.cc: ...here. * cgraph.c: Moved to... * cgraph.cc: ...here. * cgraphbuild.c: Moved to... * cgraphbuild.cc: ...here. * cgraphclones.c: Moved to... * cgraphclones.cc: ...here. * cgraphunit.c: Moved to... * cgraphunit.cc: ...here. * collect-utils.c: Moved to... * collect-utils.cc: ...here. * collect2-aix.c: Moved to... * collect2-aix.cc: ...here. * collect2.c: Moved to... * collect2.cc: ...here. * combine-stack-adj.c: Moved to... * combine-stack-adj.cc: ...here. * combine.c: Moved to... * combine.cc: ...here. * common/common-targhooks.c: Moved to... * common/common-targhooks.cc: ...here. * common/config/aarch64/aarch64-common.c: Moved to... * common/config/aarch64/aarch64-common.cc: ...here. * common/config/alpha/alpha-common.c: Moved to... * common/config/alpha/alpha-common.cc: ...here. * common/config/arc/arc-common.c: Moved to... * common/config/arc/arc-common.cc: ...here. * common/config/arm/arm-common.c: Moved to... * common/config/arm/arm-common.cc: ...here. * common/config/avr/avr-common.c: Moved to... * common/config/avr/avr-common.cc: ...here. * common/config/bfin/bfin-common.c: Moved to... * common/config/bfin/bfin-common.cc: ...here. * common/config/bpf/bpf-common.c: Moved to... * common/config/bpf/bpf-common.cc: ...here. * common/config/c6x/c6x-common.c: Moved to... * common/config/c6x/c6x-common.cc: ...here. * common/config/cr16/cr16-common.c: Moved to... * common/config/cr16/cr16-common.cc: ...here. * common/config/cris/cris-common.c: Moved to... * common/config/cris/cris-common.cc: ...here. * common/config/csky/csky-common.c: Moved to... * common/config/csky/csky-common.cc: ...here. * common/config/default-common.c: Moved to... * common/config/default-common.cc: ...here. * common/config/epiphany/epiphany-common.c: Moved to... * common/config/epiphany/epiphany-common.cc: ...here. * common/config/fr30/fr30-common.c: Moved to... * common/config/fr30/fr30-common.cc: ...here. * common/config/frv/frv-common.c: Moved to... * common/config/frv/frv-common.cc: ...here. * common/config/gcn/gcn-common.c: Moved to... * common/config/gcn/gcn-common.cc: ...here. * common/config/h8300/h8300-common.c: Moved to... * common/config/h8300/h8300-common.cc: ...here. * common/config/i386/i386-common.c: Moved to... * common/config/i386/i386-common.cc: ...here. * common/config/ia64/ia64-common.c: Moved to... * common/config/ia64/ia64-common.cc: ...here. * common/config/iq2000/iq2000-common.c: Moved to... * common/config/iq2000/iq2000-common.cc: ...here. * common/config/lm32/lm32-common.c: Moved to... * common/config/lm32/lm32-common.cc: ...here. * common/config/m32r/m32r-common.c: Moved to... * common/config/m32r/m32r-common.cc: ...here. * common/config/m68k/m68k-common.c: Moved to... * common/config/m68k/m68k-common.cc: ...here. * common/config/mcore/mcore-common.c: Moved to... * common/config/mcore/mcore-common.cc: ...here. * common/config/microblaze/microblaze-common.c: Moved to... * common/config/microblaze/microblaze-common.cc: ...here. * common/config/mips/mips-common.c: Moved to... * common/config/mips/mips-common.cc: ...here. * common/config/mmix/mmix-common.c: Moved to... * common/config/mmix/mmix-common.cc: ...here. * common/config/mn10300/mn10300-common.c: Moved to... * common/config/mn10300/mn10300-common.cc: ...here. * common/config/msp430/msp430-common.c: Moved to... * common/config/msp430/msp430-common.cc: ...here. * common/config/nds32/nds32-common.c: Moved to... * common/config/nds32/nds32-common.cc: ...here. * common/config/nios2/nios2-common.c: Moved to... * common/config/nios2/nios2-common.cc: ...here. * common/config/nvptx/nvptx-common.c: Moved to... * common/config/nvptx/nvptx-common.cc: ...here. * common/config/or1k/or1k-common.c: Moved to... * common/config/or1k/or1k-common.cc: ...here. * common/config/pa/pa-common.c: Moved to... * common/config/pa/pa-common.cc: ...here. * common/config/pdp11/pdp11-common.c: Moved to... * common/config/pdp11/pdp11-common.cc: ...here. * common/config/pru/pru-common.c: Moved to... * common/config/pru/pru-common.cc: ...here. * common/config/riscv/riscv-common.c: Moved to... * common/config/riscv/riscv-common.cc: ...here. * common/config/rs6000/rs6000-common.c: Moved to... * common/config/rs6000/rs6000-common.cc: ...here. * common/config/rx/rx-common.c: Moved to... * common/config/rx/rx-common.cc: ...here. * common/config/s390/s390-common.c: Moved to... * common/config/s390/s390-common.cc: ...here. * common/config/sh/sh-common.c: Moved to... * common/config/sh/sh-common.cc: ...here. * common/config/sparc/sparc-common.c: Moved to... * common/config/sparc/sparc-common.cc: ...here. * common/config/tilegx/tilegx-common.c: Moved to... * common/config/tilegx/tilegx-common.cc: ...here. * common/config/tilepro/tilepro-common.c: Moved to... * common/config/tilepro/tilepro-common.cc: ...here. * common/config/v850/v850-common.c: Moved to... * common/config/v850/v850-common.cc: ...here. * common/config/vax/vax-common.c: Moved to... * common/config/vax/vax-common.cc: ...here. * common/config/visium/visium-common.c: Moved to... * common/config/visium/visium-common.cc: ...here. * common/config/xstormy16/xstormy16-common.c: Moved to... * common/config/xstormy16/xstormy16-common.cc: ...here. * common/config/xtensa/xtensa-common.c: Moved to... * common/config/xtensa/xtensa-common.cc: ...here. * compare-elim.c: Moved to... * compare-elim.cc: ...here. * config/aarch64/aarch64-bti-insert.c: Moved to... * config/aarch64/aarch64-bti-insert.cc: ...here. * config/aarch64/aarch64-builtins.c: Moved to... * config/aarch64/aarch64-builtins.cc: ...here. * config/aarch64/aarch64-c.c: Moved to... * config/aarch64/aarch64-c.cc: ...here. * config/aarch64/aarch64-d.c: Moved to... * config/aarch64/aarch64-d.cc: ...here. * config/aarch64/aarch64.c: Moved to... * config/aarch64/aarch64.cc: ...here. * config/aarch64/cortex-a57-fma-steering.c: Moved to... * config/aarch64/cortex-a57-fma-steering.cc: ...here. * config/aarch64/driver-aarch64.c: Moved to... * config/aarch64/driver-aarch64.cc: ...here. * config/aarch64/falkor-tag-collision-avoidance.c: Moved to... * config/aarch64/falkor-tag-collision-avoidance.cc: ...here. * config/aarch64/host-aarch64-darwin.c: Moved to... * config/aarch64/host-aarch64-darwin.cc: ...here. * config/alpha/alpha.c: Moved to... * config/alpha/alpha.cc: ...here. * config/alpha/driver-alpha.c: Moved to... * config/alpha/driver-alpha.cc: ...here. * config/arc/arc-c.c: Moved to... * config/arc/arc-c.cc: ...here. * config/arc/arc.c: Moved to... * config/arc/arc.cc: ...here. * config/arc/driver-arc.c: Moved to... * config/arc/driver-arc.cc: ...here. * config/arm/aarch-common.c: Moved to... * config/arm/aarch-common.cc: ...here. * config/arm/arm-builtins.c: Moved to... * config/arm/arm-builtins.cc: ...here. * config/arm/arm-c.c: Moved to... * config/arm/arm-c.cc: ...here. * config/arm/arm-d.c: Moved to... * config/arm/arm-d.cc: ...here. * config/arm/arm.c: Moved to... * config/arm/arm.cc: ...here. * config/arm/driver-arm.c: Moved to... * config/arm/driver-arm.cc: ...here. * config/avr/avr-c.c: Moved to... * config/avr/avr-c.cc: ...here. * config/avr/avr-devices.c: Moved to... * config/avr/avr-devices.cc: ...here. * config/avr/avr-log.c: Moved to... * config/avr/avr-log.cc: ...here. * config/avr/avr.c: Moved to... * config/avr/avr.cc: ...here. * config/avr/driver-avr.c: Moved to... * config/avr/driver-avr.cc: ...here. * config/avr/gen-avr-mmcu-specs.c: Moved to... * config/avr/gen-avr-mmcu-specs.cc: ...here. * config/avr/gen-avr-mmcu-texi.c: Moved to... * config/avr/gen-avr-mmcu-texi.cc: ...here. * config/bfin/bfin.c: Moved to... * config/bfin/bfin.cc: ...here. * config/bpf/bpf.c: Moved to... * config/bpf/bpf.cc: ...here. * config/bpf/coreout.c: Moved to... * config/bpf/coreout.cc: ...here. * config/c6x/c6x.c: Moved to... * config/c6x/c6x.cc: ...here. * config/cr16/cr16.c: Moved to... * config/cr16/cr16.cc: ...here. * config/cris/cris.c: Moved to... * config/cris/cris.cc: ...here. * config/csky/csky.c: Moved to... * config/csky/csky.cc: ...here. * config/darwin-c.c: Moved to... * config/darwin-c.cc: ...here. * config/darwin-d.c: Moved to... * config/darwin-d.cc: ...here. * config/darwin-driver.c: Moved to... * config/darwin-driver.cc: ...here. * config/darwin-f.c: Moved to... * config/darwin-f.cc: ...here. * config/darwin.c: Moved to... * config/darwin.cc: ...here. * config/default-c.c: Moved to... * config/default-c.cc: ...here. * config/default-d.c: Moved to... * config/default-d.cc: ...here. * config/dragonfly-d.c: Moved to... * config/dragonfly-d.cc: ...here. * config/epiphany/epiphany.c: Moved to... * config/epiphany/epiphany.cc: ...here. * config/epiphany/mode-switch-use.c: Moved to... * config/epiphany/mode-switch-use.cc: ...here. * config/epiphany/resolve-sw-modes.c: Moved to... * config/epiphany/resolve-sw-modes.cc: ...here. * config/fr30/fr30.c: Moved to... * config/fr30/fr30.cc: ...here. * config/freebsd-d.c: Moved to... * config/freebsd-d.cc: ...here. * config/frv/frv.c: Moved to... * config/frv/frv.cc: ...here. * config/ft32/ft32.c: Moved to... * config/ft32/ft32.cc: ...here. * config/gcn/driver-gcn.c: Moved to... * config/gcn/driver-gcn.cc: ...here. * config/gcn/gcn-run.c: Moved to... * config/gcn/gcn-run.cc: ...here. * config/gcn/gcn-tree.c: Moved to... * config/gcn/gcn-tree.cc: ...here. * config/gcn/gcn.c: Moved to... * config/gcn/gcn.cc: ...here. * config/gcn/mkoffload.c: Moved to... * config/gcn/mkoffload.cc: ...here. * config/glibc-c.c: Moved to... * config/glibc-c.cc: ...here. * config/glibc-d.c: Moved to... * config/glibc-d.cc: ...here. * config/h8300/h8300.c: Moved to... * config/h8300/h8300.cc: ...here. * config/host-darwin.c: Moved to... * config/host-darwin.cc: ...here. * config/host-hpux.c: Moved to... * config/host-hpux.cc: ...here. * config/host-linux.c: Moved to... * config/host-linux.cc: ...here. * config/host-netbsd.c: Moved to... * config/host-netbsd.cc: ...here. * config/host-openbsd.c: Moved to... * config/host-openbsd.cc: ...here. * config/host-solaris.c: Moved to... * config/host-solaris.cc: ...here. * config/i386/djgpp.c: Moved to... * config/i386/djgpp.cc: ...here. * config/i386/driver-i386.c: Moved to... * config/i386/driver-i386.cc: ...here. * config/i386/driver-mingw32.c: Moved to... * config/i386/driver-mingw32.cc: ...here. * config/i386/gnu-property.c: Moved to... * config/i386/gnu-property.cc: ...here. * config/i386/host-cygwin.c: Moved to... * config/i386/host-cygwin.cc: ...here. * config/i386/host-i386-darwin.c: Moved to... * config/i386/host-i386-darwin.cc: ...here. * config/i386/host-mingw32.c: Moved to... * config/i386/host-mingw32.cc: ...here. * config/i386/i386-builtins.c: Moved to... * config/i386/i386-builtins.cc: ...here. * config/i386/i386-c.c: Moved to... * config/i386/i386-c.cc: ...here. * config/i386/i386-d.c: Moved to... * config/i386/i386-d.cc: ...here. * config/i386/i386-expand.c: Moved to... * config/i386/i386-expand.cc: ...here. * config/i386/i386-features.c: Moved to... * config/i386/i386-features.cc: ...here. * config/i386/i386-options.c: Moved to... * config/i386/i386-options.cc: ...here. * config/i386/i386.c: Moved to... * config/i386/i386.cc: ...here. * config/i386/intelmic-mkoffload.c: Moved to... * config/i386/intelmic-mkoffload.cc: ...here. * config/i386/msformat-c.c: Moved to... * config/i386/msformat-c.cc: ...here. * config/i386/winnt-cxx.c: Moved to... * config/i386/winnt-cxx.cc: ...here. * config/i386/winnt-d.c: Moved to... * config/i386/winnt-d.cc: ...here. * config/i386/winnt-stubs.c: Moved to... * config/i386/winnt-stubs.cc: ...here. * config/i386/winnt.c: Moved to... * config/i386/winnt.cc: ...here. * config/i386/x86-tune-sched-atom.c: Moved to... * config/i386/x86-tune-sched-atom.cc: ...here. * config/i386/x86-tune-sched-bd.c: Moved to... * config/i386/x86-tune-sched-bd.cc: ...here. * config/i386/x86-tune-sched-core.c: Moved to... * config/i386/x86-tune-sched-core.cc: ...here. * config/i386/x86-tune-sched.c: Moved to... * config/i386/x86-tune-sched.cc: ...here. * config/ia64/ia64-c.c: Moved to... * config/ia64/ia64-c.cc: ...here. * config/ia64/ia64.c: Moved to... * config/ia64/ia64.cc: ...here. * config/iq2000/iq2000.c: Moved to... * config/iq2000/iq2000.cc: ...here. * config/linux.c: Moved to... * config/linux.cc: ...here. * config/lm32/lm32.c: Moved to... * config/lm32/lm32.cc: ...here. * config/m32c/m32c-pragma.c: Moved to... * config/m32c/m32c-pragma.cc: ...here. * config/m32c/m32c.c: Moved to... * config/m32c/m32c.cc: ...here. * config/m32r/m32r.c: Moved to... * config/m32r/m32r.cc: ...here. * config/m68k/m68k.c: Moved to... * config/m68k/m68k.cc: ...here. * config/mcore/mcore.c: Moved to... * config/mcore/mcore.cc: ...here. * config/microblaze/microblaze-c.c: Moved to... * config/microblaze/microblaze-c.cc: ...here. * config/microblaze/microblaze.c: Moved to... * config/microblaze/microblaze.cc: ...here. * config/mips/driver-native.c: Moved to... * config/mips/driver-native.cc: ...here. * config/mips/frame-header-opt.c: Moved to... * config/mips/frame-header-opt.cc: ...here. * config/mips/mips-d.c: Moved to... * config/mips/mips-d.cc: ...here. * config/mips/mips.c: Moved to... * config/mips/mips.cc: ...here. * config/mmix/mmix.c: Moved to... * config/mmix/mmix.cc: ...here. * config/mn10300/mn10300.c: Moved to... * config/mn10300/mn10300.cc: ...here. * config/moxie/moxie.c: Moved to... * config/moxie/moxie.cc: ...here. * config/msp430/driver-msp430.c: Moved to... * config/msp430/driver-msp430.cc: ...here. * config/msp430/msp430-c.c: Moved to... * config/msp430/msp430-c.cc: ...here. * config/msp430/msp430-devices.c: Moved to... * config/msp430/msp430-devices.cc: ...here. * config/msp430/msp430.c: Moved to... * config/msp430/msp430.cc: ...here. * config/nds32/nds32-cost.c: Moved to... * config/nds32/nds32-cost.cc: ...here. * config/nds32/nds32-fp-as-gp.c: Moved to... * config/nds32/nds32-fp-as-gp.cc: ...here. * config/nds32/nds32-intrinsic.c: Moved to... * config/nds32/nds32-intrinsic.cc: ...here. * config/nds32/nds32-isr.c: Moved to... * config/nds32/nds32-isr.cc: ...here. * config/nds32/nds32-md-auxiliary.c: Moved to... * config/nds32/nds32-md-auxiliary.cc: ...here. * config/nds32/nds32-memory-manipulation.c: Moved to... * config/nds32/nds32-memory-manipulation.cc: ...here. * config/nds32/nds32-pipelines-auxiliary.c: Moved to... * config/nds32/nds32-pipelines-auxiliary.cc: ...here. * config/nds32/nds32-predicates.c: Moved to... * config/nds32/nds32-predicates.cc: ...here. * config/nds32/nds32-relax-opt.c: Moved to... * config/nds32/nds32-relax-opt.cc: ...here. * config/nds32/nds32-utils.c: Moved to... * config/nds32/nds32-utils.cc: ...here. * config/nds32/nds32.c: Moved to... * config/nds32/nds32.cc: ...here. * config/netbsd-d.c: Moved to... * config/netbsd-d.cc: ...here. * config/netbsd.c: Moved to... * config/netbsd.cc: ...here. * config/nios2/nios2.c: Moved to... * config/nios2/nios2.cc: ...here. * config/nvptx/mkoffload.c: Moved to... * config/nvptx/mkoffload.cc: ...here. * config/nvptx/nvptx-c.c: Moved to... * config/nvptx/nvptx-c.cc: ...here. * config/nvptx/nvptx.c: Moved to... * config/nvptx/nvptx.cc: ...here. * config/openbsd-d.c: Moved to... * config/openbsd-d.cc: ...here. * config/or1k/or1k.c: Moved to... * config/or1k/or1k.cc: ...here. * config/pa/pa-d.c: Moved to... * config/pa/pa-d.cc: ...here. * config/pa/pa.c: Moved to... * config/pa/pa.cc: ...here. * config/pdp11/pdp11.c: Moved to... * config/pdp11/pdp11.cc: ...here. * config/pru/pru-passes.c: Moved to... * config/pru/pru-passes.cc: ...here. * config/pru/pru-pragma.c: Moved to... * config/pru/pru-pragma.cc: ...here. * config/pru/pru.c: Moved to... * config/pru/pru.cc: ...here. * config/riscv/riscv-builtins.c: Moved to... * config/riscv/riscv-builtins.cc: ...here. * config/riscv/riscv-c.c: Moved to... * config/riscv/riscv-c.cc: ...here. * config/riscv/riscv-d.c: Moved to... * config/riscv/riscv-d.cc: ...here. * config/riscv/riscv-shorten-memrefs.c: Moved to... * config/riscv/riscv-shorten-memrefs.cc: ...here. * config/riscv/riscv-sr.c: Moved to... * config/riscv/riscv-sr.cc: ...here. * config/riscv/riscv.c: Moved to... * config/riscv/riscv.cc: ...here. * config/rl78/rl78-c.c: Moved to... * config/rl78/rl78-c.cc: ...here. * config/rl78/rl78.c: Moved to... * config/rl78/rl78.cc: ...here. * config/rs6000/driver-rs6000.c: Moved to... * config/rs6000/driver-rs6000.cc: ...here. * config/rs6000/host-darwin.c: Moved to... * config/rs6000/host-darwin.cc: ...here. * config/rs6000/host-ppc64-darwin.c: Moved to... * config/rs6000/host-ppc64-darwin.cc: ...here. * config/rs6000/rbtree.c: Moved to... * config/rs6000/rbtree.cc: ...here. * config/rs6000/rs6000-c.c: Moved to... * config/rs6000/rs6000-c.cc: ...here. * config/rs6000/rs6000-call.c: Moved to... * config/rs6000/rs6000-call.cc: ...here. * config/rs6000/rs6000-d.c: Moved to... * config/rs6000/rs6000-d.cc: ...here. * config/rs6000/rs6000-gen-builtins.c: Moved to... * config/rs6000/rs6000-gen-builtins.cc: ...here. * config/rs6000/rs6000-linux.c: Moved to... * config/rs6000/rs6000-linux.cc: ...here. * config/rs6000/rs6000-logue.c: Moved to... * config/rs6000/rs6000-logue.cc: ...here. * config/rs6000/rs6000-p8swap.c: Moved to... * config/rs6000/rs6000-p8swap.cc: ...here. * config/rs6000/rs6000-pcrel-opt.c: Moved to... * config/rs6000/rs6000-pcrel-opt.cc: ...here. * config/rs6000/rs6000-string.c: Moved to... * config/rs6000/rs6000-string.cc: ...here. * config/rs6000/rs6000.c: Moved to... * config/rs6000/rs6000.cc: ...here. * config/rx/rx.c: Moved to... * config/rx/rx.cc: ...here. * config/s390/driver-native.c: Moved to... * config/s390/driver-native.cc: ...here. * config/s390/s390-c.c: Moved to... * config/s390/s390-c.cc: ...here. * config/s390/s390-d.c: Moved to... * config/s390/s390-d.cc: ...here. * config/s390/s390.c: Moved to... * config/s390/s390.cc: ...here. * config/sh/divtab-sh4-300.c: Moved to... * config/sh/divtab-sh4-300.cc: ...here. * config/sh/divtab-sh4.c: Moved to... * config/sh/divtab-sh4.cc: ...here. * config/sh/divtab.c: Moved to... * config/sh/divtab.cc: ...here. * config/sh/sh-c.c: Moved to... * config/sh/sh-c.cc: ...here. * config/sh/sh.c: Moved to... * config/sh/sh.cc: ...here. * config/sol2-c.c: Moved to... * config/sol2-c.cc: ...here. * config/sol2-cxx.c: Moved to... * config/sol2-cxx.cc: ...here. * config/sol2-d.c: Moved to... * config/sol2-d.cc: ...here. * config/sol2-stubs.c: Moved to... * config/sol2-stubs.cc: ...here. * config/sol2.c: Moved to... * config/sol2.cc: ...here. * config/sparc/driver-sparc.c: Moved to... * config/sparc/driver-sparc.cc: ...here. * config/sparc/sparc-c.c: Moved to... * config/sparc/sparc-c.cc: ...here. * config/sparc/sparc-d.c: Moved to... * config/sparc/sparc-d.cc: ...here. * config/sparc/sparc.c: Moved to... * config/sparc/sparc.cc: ...here. * config/stormy16/stormy16.c: Moved to... * config/stormy16/stormy16.cc: ...here. * config/tilegx/mul-tables.c: Moved to... * config/tilegx/mul-tables.cc: ...here. * config/tilegx/tilegx-c.c: Moved to... * config/tilegx/tilegx-c.cc: ...here. * config/tilegx/tilegx.c: Moved to... * config/tilegx/tilegx.cc: ...here. * config/tilepro/mul-tables.c: Moved to... * config/tilepro/mul-tables.cc: ...here. * config/tilepro/tilepro-c.c: Moved to... * config/tilepro/tilepro-c.cc: ...here. * config/tilepro/tilepro.c: Moved to... * config/tilepro/tilepro.cc: ...here. * config/v850/v850-c.c: Moved to... * config/v850/v850-c.cc: ...here. * config/v850/v850.c: Moved to... * config/v850/v850.cc: ...here. * config/vax/vax.c: Moved to... * config/vax/vax.cc: ...here. * config/visium/visium.c: Moved to... * config/visium/visium.cc: ...here. * config/vms/vms-c.c: Moved to... * config/vms/vms-c.cc: ...here. * config/vms/vms-f.c: Moved to... * config/vms/vms-f.cc: ...here. * config/vms/vms.c: Moved to... * config/vms/vms.cc: ...here. * config/vxworks-c.c: Moved to... * config/vxworks-c.cc: ...here. * config/vxworks.c: Moved to... * config/vxworks.cc: ...here. * config/winnt-c.c: Moved to... * config/winnt-c.cc: ...here. * config/xtensa/xtensa.c: Moved to... * config/xtensa/xtensa.cc: ...here. * context.c: Moved to... * context.cc: ...here. * convert.c: Moved to... * convert.cc: ...here. * coverage.c: Moved to... * coverage.cc: ...here. * cppbuiltin.c: Moved to... * cppbuiltin.cc: ...here. * cppdefault.c: Moved to... * cppdefault.cc: ...here. * cprop.c: Moved to... * cprop.cc: ...here. * cse.c: Moved to... * cse.cc: ...here. * cselib.c: Moved to... * cselib.cc: ...here. * ctfc.c: Moved to... * ctfc.cc: ...here. * ctfout.c: Moved to... * ctfout.cc: ...here. * data-streamer-in.c: Moved to... * data-streamer-in.cc: ...here. * data-streamer-out.c: Moved to... * data-streamer-out.cc: ...here. * data-streamer.c: Moved to... * data-streamer.cc: ...here. * dbgcnt.c: Moved to... * dbgcnt.cc: ...here. * dbxout.c: Moved to... * dbxout.cc: ...here. * dce.c: Moved to... * dce.cc: ...here. * ddg.c: Moved to... * ddg.cc: ...here. * debug.c: Moved to... * debug.cc: ...here. * df-core.c: Moved to... * df-core.cc: ...here. * df-problems.c: Moved to... * df-problems.cc: ...here. * df-scan.c: Moved to... * df-scan.cc: ...here. * dfp.c: Moved to... * dfp.cc: ...here. * diagnostic-color.c: Moved to... * diagnostic-color.cc: ...here. * diagnostic-show-locus.c: Moved to... * diagnostic-show-locus.cc: ...here. * diagnostic-spec.c: Moved to... * diagnostic-spec.cc: ...here. * diagnostic.c: Moved to... * diagnostic.cc: ...here. * dojump.c: Moved to... * dojump.cc: ...here. * dominance.c: Moved to... * dominance.cc: ...here. * domwalk.c: Moved to... * domwalk.cc: ...here. * double-int.c: Moved to... * double-int.cc: ...here. * dse.c: Moved to... * dse.cc: ...here. * dumpfile.c: Moved to... * dumpfile.cc: ...here. * dwarf2asm.c: Moved to... * dwarf2asm.cc: ...here. * dwarf2cfi.c: Moved to... * dwarf2cfi.cc: ...here. * dwarf2ctf.c: Moved to... * dwarf2ctf.cc: ...here. * dwarf2out.c: Moved to... * dwarf2out.cc: ...here. * early-remat.c: Moved to... * early-remat.cc: ...here. * edit-context.c: Moved to... * edit-context.cc: ...here. * emit-rtl.c: Moved to... * emit-rtl.cc: ...here. * errors.c: Moved to... * errors.cc: ...here. * et-forest.c: Moved to... * et-forest.cc: ...here. * except.c: Moved to... * except.cc: ...here. * explow.c: Moved to... * explow.cc: ...here. * expmed.c: Moved to... * expmed.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * fibonacci_heap.c: Moved to... * fibonacci_heap.cc: ...here. * file-find.c: Moved to... * file-find.cc: ...here. * file-prefix-map.c: Moved to... * file-prefix-map.cc: ...here. * final.c: Moved to... * final.cc: ...here. * fixed-value.c: Moved to... * fixed-value.cc: ...here. * fold-const-call.c: Moved to... * fold-const-call.cc: ...here. * fold-const.c: Moved to... * fold-const.cc: ...here. * fp-test.c: Moved to... * fp-test.cc: ...here. * function-tests.c: Moved to... * function-tests.cc: ...here. * function.c: Moved to... * function.cc: ...here. * fwprop.c: Moved to... * fwprop.cc: ...here. * gcc-ar.c: Moved to... * gcc-ar.cc: ...here. * gcc-main.c: Moved to... * gcc-main.cc: ...here. * gcc-rich-location.c: Moved to... * gcc-rich-location.cc: ...here. * gcc.c: Moved to... * gcc.cc: ...here. * gcov-dump.c: Moved to... * gcov-dump.cc: ...here. * gcov-io.c: Moved to... * gcov-io.cc: ...here. * gcov-tool.c: Moved to... * gcov-tool.cc: ...here. * gcov.c: Moved to... * gcov.cc: ...here. * gcse-common.c: Moved to... * gcse-common.cc: ...here. * gcse.c: Moved to... * gcse.cc: ...here. * genattr-common.c: Moved to... * genattr-common.cc: ...here. * genattr.c: Moved to... * genattr.cc: ...here. * genattrtab.c: Moved to... * genattrtab.cc: ...here. * genautomata.c: Moved to... * genautomata.cc: ...here. * gencfn-macros.c: Moved to... * gencfn-macros.cc: ...here. * gencheck.c: Moved to... * gencheck.cc: ...here. * genchecksum.c: Moved to... * genchecksum.cc: ...here. * gencodes.c: Moved to... * gencodes.cc: ...here. * genconditions.c: Moved to... * genconditions.cc: ...here. * genconfig.c: Moved to... * genconfig.cc: ...here. * genconstants.c: Moved to... * genconstants.cc: ...here. * genemit.c: Moved to... * genemit.cc: ...here. * genenums.c: Moved to... * genenums.cc: ...here. * generic-match-head.c: Moved to... * generic-match-head.cc: ...here. * genextract.c: Moved to... * genextract.cc: ...here. * genflags.c: Moved to... * genflags.cc: ...here. * gengenrtl.c: Moved to... * gengenrtl.cc: ...here. * gengtype-parse.c: Moved to... * gengtype-parse.cc: ...here. * gengtype-state.c: Moved to... * gengtype-state.cc: ...here. * gengtype.c: Moved to... * gengtype.cc: ...here. * genhooks.c: Moved to... * genhooks.cc: ...here. * genmatch.c: Moved to... * genmatch.cc: ...here. * genmddeps.c: Moved to... * genmddeps.cc: ...here. * genmddump.c: Moved to... * genmddump.cc: ...here. * genmodes.c: Moved to... * genmodes.cc: ...here. * genopinit.c: Moved to... * genopinit.cc: ...here. * genoutput.c: Moved to... * genoutput.cc: ...here. * genpeep.c: Moved to... * genpeep.cc: ...here. * genpreds.c: Moved to... * genpreds.cc: ...here. * genrecog.c: Moved to... * genrecog.cc: ...here. * gensupport.c: Moved to... * gensupport.cc: ...here. * gentarget-def.c: Moved to... * gentarget-def.cc: ...here. * genversion.c: Moved to... * genversion.cc: ...here. * ggc-common.c: Moved to... * ggc-common.cc: ...here. * ggc-none.c: Moved to... * ggc-none.cc: ...here. * ggc-page.c: Moved to... * ggc-page.cc: ...here. * ggc-tests.c: Moved to... * ggc-tests.cc: ...here. * gimple-builder.c: Moved to... * gimple-builder.cc: ...here. * gimple-expr.c: Moved to... * gimple-expr.cc: ...here. * gimple-fold.c: Moved to... * gimple-fold.cc: ...here. * gimple-iterator.c: Moved to... * gimple-iterator.cc: ...here. * gimple-laddress.c: Moved to... * gimple-laddress.cc: ...here. * gimple-loop-jam.c: Moved to... * gimple-loop-jam.cc: ...here. * gimple-low.c: Moved to... * gimple-low.cc: ...here. * gimple-match-head.c: Moved to... * gimple-match-head.cc: ...here. * gimple-pretty-print.c: Moved to... * gimple-pretty-print.cc: ...here. * gimple-ssa-backprop.c: Moved to... * gimple-ssa-backprop.cc: ...here. * gimple-ssa-evrp-analyze.c: Moved to... * gimple-ssa-evrp-analyze.cc: ...here. * gimple-ssa-evrp.c: Moved to... * gimple-ssa-evrp.cc: ...here. * gimple-ssa-isolate-paths.c: Moved to... * gimple-ssa-isolate-paths.cc: ...here. * gimple-ssa-nonnull-compare.c: Moved to... * gimple-ssa-nonnull-compare.cc: ...here. * gimple-ssa-split-paths.c: Moved to... * gimple-ssa-split-paths.cc: ...here. * gimple-ssa-sprintf.c: Moved to... * gimple-ssa-sprintf.cc: ...here. * gimple-ssa-store-merging.c: Moved to... * gimple-ssa-store-merging.cc: ...here. * gimple-ssa-strength-reduction.c: Moved to... * gimple-ssa-strength-reduction.cc: ...here. * gimple-ssa-warn-alloca.c: Moved to... * gimple-ssa-warn-alloca.cc: ...here. * gimple-ssa-warn-restrict.c: Moved to... * gimple-ssa-warn-restrict.cc: ...here. * gimple-streamer-in.c: Moved to... * gimple-streamer-in.cc: ...here. * gimple-streamer-out.c: Moved to... * gimple-streamer-out.cc: ...here. * gimple-walk.c: Moved to... * gimple-walk.cc: ...here. * gimple-warn-recursion.c: Moved to... * gimple-warn-recursion.cc: ...here. * gimple.c: Moved to... * gimple.cc: ...here. * gimplify-me.c: Moved to... * gimplify-me.cc: ...here. * gimplify.c: Moved to... * gimplify.cc: ...here. * godump.c: Moved to... * godump.cc: ...here. * graph.c: Moved to... * graph.cc: ...here. * graphds.c: Moved to... * graphds.cc: ...here. * graphite-dependences.c: Moved to... * graphite-dependences.cc: ...here. * graphite-isl-ast-to-gimple.c: Moved to... * graphite-isl-ast-to-gimple.cc: ...here. * graphite-optimize-isl.c: Moved to... * graphite-optimize-isl.cc: ...here. * graphite-poly.c: Moved to... * graphite-poly.cc: ...here. * graphite-scop-detection.c: Moved to... * graphite-scop-detection.cc: ...here. * graphite-sese-to-poly.c: Moved to... * graphite-sese-to-poly.cc: ...here. * graphite.c: Moved to... * graphite.cc: ...here. * haifa-sched.c: Moved to... * haifa-sched.cc: ...here. * hash-map-tests.c: Moved to... * hash-map-tests.cc: ...here. * hash-set-tests.c: Moved to... * hash-set-tests.cc: ...here. * hash-table.c: Moved to... * hash-table.cc: ...here. * hooks.c: Moved to... * hooks.cc: ...here. * host-default.c: Moved to... * host-default.cc: ...here. * hw-doloop.c: Moved to... * hw-doloop.cc: ...here. * hwint.c: Moved to... * hwint.cc: ...here. * ifcvt.c: Moved to... * ifcvt.cc: ...here. * inchash.c: Moved to... * inchash.cc: ...here. * incpath.c: Moved to... * incpath.cc: ...here. * init-regs.c: Moved to... * init-regs.cc: ...here. * input.c: Moved to... * input.cc: ...here. * internal-fn.c: Moved to... * internal-fn.cc: ...here. * intl.c: Moved to... * intl.cc: ...here. * ipa-comdats.c: Moved to... * ipa-comdats.cc: ...here. * ipa-cp.c: Moved to... * ipa-cp.cc: ...here. * ipa-devirt.c: Moved to... * ipa-devirt.cc: ...here. * ipa-fnsummary.c: Moved to... * ipa-fnsummary.cc: ...here. * ipa-icf-gimple.c: Moved to... * ipa-icf-gimple.cc: ...here. * ipa-icf.c: Moved to... * ipa-icf.cc: ...here. * ipa-inline-analysis.c: Moved to... * ipa-inline-analysis.cc: ...here. * ipa-inline-transform.c: Moved to... * ipa-inline-transform.cc: ...here. * ipa-inline.c: Moved to... * ipa-inline.cc: ...here. * ipa-modref-tree.c: Moved to... * ipa-modref-tree.cc: ...here. * ipa-modref.c: Moved to... * ipa-modref.cc: ...here. * ipa-param-manipulation.c: Moved to... * ipa-param-manipulation.cc: ...here. * ipa-polymorphic-call.c: Moved to... * ipa-polymorphic-call.cc: ...here. * ipa-predicate.c: Moved to... * ipa-predicate.cc: ...here. * ipa-profile.c: Moved to... * ipa-profile.cc: ...here. * ipa-prop.c: Moved to... * ipa-prop.cc: ...here. * ipa-pure-const.c: Moved to... * ipa-pure-const.cc: ...here. * ipa-ref.c: Moved to... * ipa-ref.cc: ...here. * ipa-reference.c: Moved to... * ipa-reference.cc: ...here. * ipa-split.c: Moved to... * ipa-split.cc: ...here. * ipa-sra.c: Moved to... * ipa-sra.cc: ...here. * ipa-utils.c: Moved to... * ipa-utils.cc: ...here. * ipa-visibility.c: Moved to... * ipa-visibility.cc: ...here. * ipa.c: Moved to... * ipa.cc: ...here. * ira-build.c: Moved to... * ira-build.cc: ...here. * ira-color.c: Moved to... * ira-color.cc: ...here. * ira-conflicts.c: Moved to... * ira-conflicts.cc: ...here. * ira-costs.c: Moved to... * ira-costs.cc: ...here. * ira-emit.c: Moved to... * ira-emit.cc: ...here. * ira-lives.c: Moved to... * ira-lives.cc: ...here. * ira.c: Moved to... * ira.cc: ...here. * jump.c: Moved to... * jump.cc: ...here. * langhooks.c: Moved to... * langhooks.cc: ...here. * lcm.c: Moved to... * lcm.cc: ...here. * lists.c: Moved to... * lists.cc: ...here. * loop-doloop.c: Moved to... * loop-doloop.cc: ...here. * loop-init.c: Moved to... * loop-init.cc: ...here. * loop-invariant.c: Moved to... * loop-invariant.cc: ...here. * loop-iv.c: Moved to... * loop-iv.cc: ...here. * loop-unroll.c: Moved to... * loop-unroll.cc: ...here. * lower-subreg.c: Moved to... * lower-subreg.cc: ...here. * lra-assigns.c: Moved to... * lra-assigns.cc: ...here. * lra-coalesce.c: Moved to... * lra-coalesce.cc: ...here. * lra-constraints.c: Moved to... * lra-constraints.cc: ...here. * lra-eliminations.c: Moved to... * lra-eliminations.cc: ...here. * lra-lives.c: Moved to... * lra-lives.cc: ...here. * lra-remat.c: Moved to... * lra-remat.cc: ...here. * lra-spills.c: Moved to... * lra-spills.cc: ...here. * lra.c: Moved to... * lra.cc: ...here. * lto-cgraph.c: Moved to... * lto-cgraph.cc: ...here. * lto-compress.c: Moved to... * lto-compress.cc: ...here. * lto-opts.c: Moved to... * lto-opts.cc: ...here. * lto-section-in.c: Moved to... * lto-section-in.cc: ...here. * lto-section-out.c: Moved to... * lto-section-out.cc: ...here. * lto-streamer-in.c: Moved to... * lto-streamer-in.cc: ...here. * lto-streamer-out.c: Moved to... * lto-streamer-out.cc: ...here. * lto-streamer.c: Moved to... * lto-streamer.cc: ...here. * lto-wrapper.c: Moved to... * lto-wrapper.cc: ...here. * main.c: Moved to... * main.cc: ...here. * mcf.c: Moved to... * mcf.cc: ...here. * mode-switching.c: Moved to... * mode-switching.cc: ...here. * modulo-sched.c: Moved to... * modulo-sched.cc: ...here. * multiple_target.c: Moved to... * multiple_target.cc: ...here. * omp-expand.c: Moved to... * omp-expand.cc: ...here. * omp-general.c: Moved to... * omp-general.cc: ...here. * omp-low.c: Moved to... * omp-low.cc: ...here. * omp-offload.c: Moved to... * omp-offload.cc: ...here. * omp-simd-clone.c: Moved to... * omp-simd-clone.cc: ...here. * opt-suggestions.c: Moved to... * opt-suggestions.cc: ...here. * optabs-libfuncs.c: Moved to... * optabs-libfuncs.cc: ...here. * optabs-query.c: Moved to... * optabs-query.cc: ...here. * optabs-tree.c: Moved to... * optabs-tree.cc: ...here. * optabs.c: Moved to... * optabs.cc: ...here. * opts-common.c: Moved to... * opts-common.cc: ...here. * opts-global.c: Moved to... * opts-global.cc: ...here. * opts.c: Moved to... * opts.cc: ...here. * passes.c: Moved to... * passes.cc: ...here. * plugin.c: Moved to... * plugin.cc: ...here. * postreload-gcse.c: Moved to... * postreload-gcse.cc: ...here. * postreload.c: Moved to... * postreload.cc: ...here. * predict.c: Moved to... * predict.cc: ...here. * prefix.c: Moved to... * prefix.cc: ...here. * pretty-print.c: Moved to... * pretty-print.cc: ...here. * print-rtl-function.c: Moved to... * print-rtl-function.cc: ...here. * print-rtl.c: Moved to... * print-rtl.cc: ...here. * print-tree.c: Moved to... * print-tree.cc: ...here. * profile-count.c: Moved to... * profile-count.cc: ...here. * profile.c: Moved to... * profile.cc: ...here. * read-md.c: Moved to... * read-md.cc: ...here. * read-rtl-function.c: Moved to... * read-rtl-function.cc: ...here. * read-rtl.c: Moved to... * read-rtl.cc: ...here. * real.c: Moved to... * real.cc: ...here. * realmpfr.c: Moved to... * realmpfr.cc: ...here. * recog.c: Moved to... * recog.cc: ...here. * ree.c: Moved to... * ree.cc: ...here. * reg-stack.c: Moved to... * reg-stack.cc: ...here. * regcprop.c: Moved to... * regcprop.cc: ...here. * reginfo.c: Moved to... * reginfo.cc: ...here. * regrename.c: Moved to... * regrename.cc: ...here. * regstat.c: Moved to... * regstat.cc: ...here. * reload.c: Moved to... * reload.cc: ...here. * reload1.c: Moved to... * reload1.cc: ...here. * reorg.c: Moved to... * reorg.cc: ...here. * resource.c: Moved to... * resource.cc: ...here. * rtl-error.c: Moved to... * rtl-error.cc: ...here. * rtl-tests.c: Moved to... * rtl-tests.cc: ...here. * rtl.c: Moved to... * rtl.cc: ...here. * rtlanal.c: Moved to... * rtlanal.cc: ...here. * rtlhash.c: Moved to... * rtlhash.cc: ...here. * rtlhooks.c: Moved to... * rtlhooks.cc: ...here. * rtx-vector-builder.c: Moved to... * rtx-vector-builder.cc: ...here. * run-rtl-passes.c: Moved to... * run-rtl-passes.cc: ...here. * sancov.c: Moved to... * sancov.cc: ...here. * sanopt.c: Moved to... * sanopt.cc: ...here. * sbitmap.c: Moved to... * sbitmap.cc: ...here. * sched-deps.c: Moved to... * sched-deps.cc: ...here. * sched-ebb.c: Moved to... * sched-ebb.cc: ...here. * sched-rgn.c: Moved to... * sched-rgn.cc: ...here. * sel-sched-dump.c: Moved to... * sel-sched-dump.cc: ...here. * sel-sched-ir.c: Moved to... * sel-sched-ir.cc: ...here. * sel-sched.c: Moved to... * sel-sched.cc: ...here. * selftest-diagnostic.c: Moved to... * selftest-diagnostic.cc: ...here. * selftest-rtl.c: Moved to... * selftest-rtl.cc: ...here. * selftest-run-tests.c: Moved to... * selftest-run-tests.cc: ...here. * selftest.c: Moved to... * selftest.cc: ...here. * sese.c: Moved to... * sese.cc: ...here. * shrink-wrap.c: Moved to... * shrink-wrap.cc: ...here. * simplify-rtx.c: Moved to... * simplify-rtx.cc: ...here. * sparseset.c: Moved to... * sparseset.cc: ...here. * spellcheck-tree.c: Moved to... * spellcheck-tree.cc: ...here. * spellcheck.c: Moved to... * spellcheck.cc: ...here. * sreal.c: Moved to... * sreal.cc: ...here. * stack-ptr-mod.c: Moved to... * stack-ptr-mod.cc: ...here. * statistics.c: Moved to... * statistics.cc: ...here. * stmt.c: Moved to... * stmt.cc: ...here. * stor-layout.c: Moved to... * stor-layout.cc: ...here. * store-motion.c: Moved to... * store-motion.cc: ...here. * streamer-hooks.c: Moved to... * streamer-hooks.cc: ...here. * stringpool.c: Moved to... * stringpool.cc: ...here. * substring-locations.c: Moved to... * substring-locations.cc: ...here. * symtab.c: Moved to... * symtab.cc: ...here. * target-globals.c: Moved to... * target-globals.cc: ...here. * targhooks.c: Moved to... * targhooks.cc: ...here. * timevar.c: Moved to... * timevar.cc: ...here. * toplev.c: Moved to... * toplev.cc: ...here. * tracer.c: Moved to... * tracer.cc: ...here. * trans-mem.c: Moved to... * trans-mem.cc: ...here. * tree-affine.c: Moved to... * tree-affine.cc: ...here. * tree-call-cdce.c: Moved to... * tree-call-cdce.cc: ...here. * tree-cfg.c: Moved to... * tree-cfg.cc: ...here. * tree-cfgcleanup.c: Moved to... * tree-cfgcleanup.cc: ...here. * tree-chrec.c: Moved to... * tree-chrec.cc: ...here. * tree-complex.c: Moved to... * tree-complex.cc: ...here. * tree-data-ref.c: Moved to... * tree-data-ref.cc: ...here. * tree-dfa.c: Moved to... * tree-dfa.cc: ...here. * tree-diagnostic.c: Moved to... * tree-diagnostic.cc: ...here. * tree-dump.c: Moved to... * tree-dump.cc: ...here. * tree-eh.c: Moved to... * tree-eh.cc: ...here. * tree-emutls.c: Moved to... * tree-emutls.cc: ...here. * tree-if-conv.c: Moved to... * tree-if-conv.cc: ...here. * tree-inline.c: Moved to... * tree-inline.cc: ...here. * tree-into-ssa.c: Moved to... * tree-into-ssa.cc: ...here. * tree-iterator.c: Moved to... * tree-iterator.cc: ...here. * tree-loop-distribution.c: Moved to... * tree-loop-distribution.cc: ...here. * tree-nested.c: Moved to... * tree-nested.cc: ...here. * tree-nrv.c: Moved to... * tree-nrv.cc: ...here. * tree-object-size.c: Moved to... * tree-object-size.cc: ...here. * tree-outof-ssa.c: Moved to... * tree-outof-ssa.cc: ...here. * tree-parloops.c: Moved to... * tree-parloops.cc: ...here. * tree-phinodes.c: Moved to... * tree-phinodes.cc: ...here. * tree-predcom.c: Moved to... * tree-predcom.cc: ...here. * tree-pretty-print.c: Moved to... * tree-pretty-print.cc: ...here. * tree-profile.c: Moved to... * tree-profile.cc: ...here. * tree-scalar-evolution.c: Moved to... * tree-scalar-evolution.cc: ...here. * tree-sra.c: Moved to... * tree-sra.cc: ...here. * tree-ssa-address.c: Moved to... * tree-ssa-address.cc: ...here. * tree-ssa-alias.c: Moved to... * tree-ssa-alias.cc: ...here. * tree-ssa-ccp.c: Moved to... * tree-ssa-ccp.cc: ...here. * tree-ssa-coalesce.c: Moved to... * tree-ssa-coalesce.cc: ...here. * tree-ssa-copy.c: Moved to... * tree-ssa-copy.cc: ...here. * tree-ssa-dce.c: Moved to... * tree-ssa-dce.cc: ...here. * tree-ssa-dom.c: Moved to... * tree-ssa-dom.cc: ...here. * tree-ssa-dse.c: Moved to... * tree-ssa-dse.cc: ...here. * tree-ssa-forwprop.c: Moved to... * tree-ssa-forwprop.cc: ...here. * tree-ssa-ifcombine.c: Moved to... * tree-ssa-ifcombine.cc: ...here. * tree-ssa-live.c: Moved to... * tree-ssa-live.cc: ...here. * tree-ssa-loop-ch.c: Moved to... * tree-ssa-loop-ch.cc: ...here. * tree-ssa-loop-im.c: Moved to... * tree-ssa-loop-im.cc: ...here. * tree-ssa-loop-ivcanon.c: Moved to... * tree-ssa-loop-ivcanon.cc: ...here. * tree-ssa-loop-ivopts.c: Moved to... * tree-ssa-loop-ivopts.cc: ...here. * tree-ssa-loop-manip.c: Moved to... * tree-ssa-loop-manip.cc: ...here. * tree-ssa-loop-niter.c: Moved to... * tree-ssa-loop-niter.cc: ...here. * tree-ssa-loop-prefetch.c: Moved to... * tree-ssa-loop-prefetch.cc: ...here. * tree-ssa-loop-split.c: Moved to... * tree-ssa-loop-split.cc: ...here. * tree-ssa-loop-unswitch.c: Moved to... * tree-ssa-loop-unswitch.cc: ...here. * tree-ssa-loop.c: Moved to... * tree-ssa-loop.cc: ...here. * tree-ssa-math-opts.c: Moved to... * tree-ssa-math-opts.cc: ...here. * tree-ssa-operands.c: Moved to... * tree-ssa-operands.cc: ...here. * tree-ssa-phiopt.c: Moved to... * tree-ssa-phiopt.cc: ...here. * tree-ssa-phiprop.c: Moved to... * tree-ssa-phiprop.cc: ...here. * tree-ssa-pre.c: Moved to... * tree-ssa-pre.cc: ...here. * tree-ssa-propagate.c: Moved to... * tree-ssa-propagate.cc: ...here. * tree-ssa-reassoc.c: Moved to... * tree-ssa-reassoc.cc: ...here. * tree-ssa-sccvn.c: Moved to... * tree-ssa-sccvn.cc: ...here. * tree-ssa-scopedtables.c: Moved to... * tree-ssa-scopedtables.cc: ...here. * tree-ssa-sink.c: Moved to... * tree-ssa-sink.cc: ...here. * tree-ssa-strlen.c: Moved to... * tree-ssa-strlen.cc: ...here. * tree-ssa-structalias.c: Moved to... * tree-ssa-structalias.cc: ...here. * tree-ssa-tail-merge.c: Moved to... * tree-ssa-tail-merge.cc: ...here. * tree-ssa-ter.c: Moved to... * tree-ssa-ter.cc: ...here. * tree-ssa-threadbackward.c: Moved to... * tree-ssa-threadbackward.cc: ...here. * tree-ssa-threadedge.c: Moved to... * tree-ssa-threadedge.cc: ...here. * tree-ssa-threadupdate.c: Moved to... * tree-ssa-threadupdate.cc: ...here. * tree-ssa-uncprop.c: Moved to... * tree-ssa-uncprop.cc: ...here. * tree-ssa-uninit.c: Moved to... * tree-ssa-uninit.cc: ...here. * tree-ssa.c: Moved to... * tree-ssa.cc: ...here. * tree-ssanames.c: Moved to... * tree-ssanames.cc: ...here. * tree-stdarg.c: Moved to... * tree-stdarg.cc: ...here. * tree-streamer-in.c: Moved to... * tree-streamer-in.cc: ...here. * tree-streamer-out.c: Moved to... * tree-streamer-out.cc: ...here. * tree-streamer.c: Moved to... * tree-streamer.cc: ...here. * tree-switch-conversion.c: Moved to... * tree-switch-conversion.cc: ...here. * tree-tailcall.c: Moved to... * tree-tailcall.cc: ...here. * tree-vect-data-refs.c: Moved to... * tree-vect-data-refs.cc: ...here. * tree-vect-generic.c: Moved to... * tree-vect-generic.cc: ...here. * tree-vect-loop-manip.c: Moved to... * tree-vect-loop-manip.cc: ...here. * tree-vect-loop.c: Moved to... * tree-vect-loop.cc: ...here. * tree-vect-patterns.c: Moved to... * tree-vect-patterns.cc: ...here. * tree-vect-slp-patterns.c: Moved to... * tree-vect-slp-patterns.cc: ...here. * tree-vect-slp.c: Moved to... * tree-vect-slp.cc: ...here. * tree-vect-stmts.c: Moved to... * tree-vect-stmts.cc: ...here. * tree-vector-builder.c: Moved to... * tree-vector-builder.cc: ...here. * tree-vectorizer.c: Moved to... * tree-vectorizer.cc: ...here. * tree-vrp.c: Moved to... * tree-vrp.cc: ...here. * tree.c: Moved to... * tree.cc: ...here. * tsan.c: Moved to... * tsan.cc: ...here. * typed-splay-tree.c: Moved to... * typed-splay-tree.cc: ...here. * ubsan.c: Moved to... * ubsan.cc: ...here. * valtrack.c: Moved to... * valtrack.cc: ...here. * value-prof.c: Moved to... * value-prof.cc: ...here. * var-tracking.c: Moved to... * var-tracking.cc: ...here. * varasm.c: Moved to... * varasm.cc: ...here. * varpool.c: Moved to... * varpool.cc: ...here. * vec-perm-indices.c: Moved to... * vec-perm-indices.cc: ...here. * vec.c: Moved to... * vec.cc: ...here. * vmsdbgout.c: Moved to... * vmsdbgout.cc: ...here. * vr-values.c: Moved to... * vr-values.cc: ...here. * vtable-verify.c: Moved to... * vtable-verify.cc: ...here. * web.c: Moved to... * web.cc: ...here. * xcoffout.c: Moved to... * xcoffout.cc: ...here. gcc/c-family/ChangeLog: * c-ada-spec.c: Moved to... * c-ada-spec.cc: ...here. * c-attribs.c: Moved to... * c-attribs.cc: ...here. * c-common.c: Moved to... * c-common.cc: ...here. * c-cppbuiltin.c: Moved to... * c-cppbuiltin.cc: ...here. * c-dump.c: Moved to... * c-dump.cc: ...here. * c-format.c: Moved to... * c-format.cc: ...here. * c-gimplify.c: Moved to... * c-gimplify.cc: ...here. * c-indentation.c: Moved to... * c-indentation.cc: ...here. * c-lex.c: Moved to... * c-lex.cc: ...here. * c-omp.c: Moved to... * c-omp.cc: ...here. * c-opts.c: Moved to... * c-opts.cc: ...here. * c-pch.c: Moved to... * c-pch.cc: ...here. * c-ppoutput.c: Moved to... * c-ppoutput.cc: ...here. * c-pragma.c: Moved to... * c-pragma.cc: ...here. * c-pretty-print.c: Moved to... * c-pretty-print.cc: ...here. * c-semantics.c: Moved to... * c-semantics.cc: ...here. * c-ubsan.c: Moved to... * c-ubsan.cc: ...here. * c-warn.c: Moved to... * c-warn.cc: ...here. * cppspec.c: Moved to... * cppspec.cc: ...here. * stub-objc.c: Moved to... * stub-objc.cc: ...here. gcc/c/ChangeLog: * c-aux-info.c: Moved to... * c-aux-info.cc: ...here. * c-convert.c: Moved to... * c-convert.cc: ...here. * c-decl.c: Moved to... * c-decl.cc: ...here. * c-errors.c: Moved to... * c-errors.cc: ...here. * c-fold.c: Moved to... * c-fold.cc: ...here. * c-lang.c: Moved to... * c-lang.cc: ...here. * c-objc-common.c: Moved to... * c-objc-common.cc: ...here. * c-parser.c: Moved to... * c-parser.cc: ...here. * c-typeck.c: Moved to... * c-typeck.cc: ...here. * gccspec.c: Moved to... * gccspec.cc: ...here. * gimple-parser.c: Moved to... * gimple-parser.cc: ...here. gcc/cp/ChangeLog: * call.c: Moved to... * call.cc: ...here. * class.c: Moved to... * class.cc: ...here. * constexpr.c: Moved to... * constexpr.cc: ...here. * cp-gimplify.c: Moved to... * cp-gimplify.cc: ...here. * cp-lang.c: Moved to... * cp-lang.cc: ...here. * cp-objcp-common.c: Moved to... * cp-objcp-common.cc: ...here. * cp-ubsan.c: Moved to... * cp-ubsan.cc: ...here. * cvt.c: Moved to... * cvt.cc: ...here. * cxx-pretty-print.c: Moved to... * cxx-pretty-print.cc: ...here. * decl.c: Moved to... * decl.cc: ...here. * decl2.c: Moved to... * decl2.cc: ...here. * dump.c: Moved to... * dump.cc: ...here. * error.c: Moved to... * error.cc: ...here. * except.c: Moved to... * except.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * friend.c: Moved to... * friend.cc: ...here. * g++spec.c: Moved to... * g++spec.cc: ...here. * init.c: Moved to... * init.cc: ...here. * lambda.c: Moved to... * lambda.cc: ...here. * lex.c: Moved to... * lex.cc: ...here. * mangle.c: Moved to... * mangle.cc: ...here. * method.c: Moved to... * method.cc: ...here. * name-lookup.c: Moved to... * name-lookup.cc: ...here. * optimize.c: Moved to... * optimize.cc: ...here. * parser.c: Moved to... * parser.cc: ...here. * pt.c: Moved to... * pt.cc: ...here. * ptree.c: Moved to... * ptree.cc: ...here. * rtti.c: Moved to... * rtti.cc: ...here. * search.c: Moved to... * search.cc: ...here. * semantics.c: Moved to... * semantics.cc: ...here. * tree.c: Moved to... * tree.cc: ...here. * typeck.c: Moved to... * typeck.cc: ...here. * typeck2.c: Moved to... * typeck2.cc: ...here. * vtable-class-hierarchy.c: Moved to... * vtable-class-hierarchy.cc: ...here. gcc/fortran/ChangeLog: * arith.c: Moved to... * arith.cc: ...here. * array.c: Moved to... * array.cc: ...here. * bbt.c: Moved to... * bbt.cc: ...here. * check.c: Moved to... * check.cc: ...here. * class.c: Moved to... * class.cc: ...here. * constructor.c: Moved to... * constructor.cc: ...here. * convert.c: Moved to... * convert.cc: ...here. * cpp.c: Moved to... * cpp.cc: ...here. * data.c: Moved to... * data.cc: ...here. * decl.c: Moved to... * decl.cc: ...here. * dependency.c: Moved to... * dependency.cc: ...here. * dump-parse-tree.c: Moved to... * dump-parse-tree.cc: ...here. * error.c: Moved to... * error.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * f95-lang.c: Moved to... * f95-lang.cc: ...here. * frontend-passes.c: Moved to... * frontend-passes.cc: ...here. * gfortranspec.c: Moved to... * gfortranspec.cc: ...here. * interface.c: Moved to... * interface.cc: ...here. * intrinsic.c: Moved to... * intrinsic.cc: ...here. * io.c: Moved to... * io.cc: ...here. * iresolve.c: Moved to... * iresolve.cc: ...here. * match.c: Moved to... * match.cc: ...here. * matchexp.c: Moved to... * matchexp.cc: ...here. * misc.c: Moved to... * misc.cc: ...here. * module.c: Moved to... * module.cc: ...here. * openmp.c: Moved to... * openmp.cc: ...here. * options.c: Moved to... * options.cc: ...here. * parse.c: Moved to... * parse.cc: ...here. * primary.c: Moved to... * primary.cc: ...here. * resolve.c: Moved to... * resolve.cc: ...here. * scanner.c: Moved to... * scanner.cc: ...here. * simplify.c: Moved to... * simplify.cc: ...here. * st.c: Moved to... * st.cc: ...here. * symbol.c: Moved to... * symbol.cc: ...here. * target-memory.c: Moved to... * target-memory.cc: ...here. * trans-array.c: Moved to... * trans-array.cc: ...here. * trans-common.c: Moved to... * trans-common.cc: ...here. * trans-const.c: Moved to... * trans-const.cc: ...here. * trans-decl.c: Moved to... * trans-decl.cc: ...here. * trans-expr.c: Moved to... * trans-expr.cc: ...here. * trans-intrinsic.c: Moved to... * trans-intrinsic.cc: ...here. * trans-io.c: Moved to... * trans-io.cc: ...here. * trans-openmp.c: Moved to... * trans-openmp.cc: ...here. * trans-stmt.c: Moved to... * trans-stmt.cc: ...here. * trans-types.c: Moved to... * trans-types.cc: ...here. * trans.c: Moved to... * trans.cc: ...here. gcc/go/ChangeLog: * go-backend.c: Moved to... * go-backend.cc: ...here. * go-lang.c: Moved to... * go-lang.cc: ...here. * gospec.c: Moved to... * gospec.cc: ...here. gcc/jit/ChangeLog: * dummy-frontend.c: Moved to... * dummy-frontend.cc: ...here. * jit-builtins.c: Moved to... * jit-builtins.cc: ...here. * jit-logging.c: Moved to... * jit-logging.cc: ...here. * jit-playback.c: Moved to... * jit-playback.cc: ...here. * jit-recording.c: Moved to... * jit-recording.cc: ...here. * jit-result.c: Moved to... * jit-result.cc: ...here. * jit-spec.c: Moved to... * jit-spec.cc: ...here. * jit-tempdir.c: Moved to... * jit-tempdir.cc: ...here. * jit-w32.c: Moved to... * jit-w32.cc: ...here. * libgccjit.c: Moved to... * libgccjit.cc: ...here. gcc/lto/ChangeLog: * common.c: Moved to... * common.cc: ...here. * lto-common.c: Moved to... * lto-common.cc: ...here. * lto-dump.c: Moved to... * lto-dump.cc: ...here. * lto-lang.c: Moved to... * lto-lang.cc: ...here. * lto-object.c: Moved to... * lto-object.cc: ...here. * lto-partition.c: Moved to... * lto-partition.cc: ...here. * lto-symtab.c: Moved to... * lto-symtab.cc: ...here. * lto.c: Moved to... * lto.cc: ...here. gcc/objc/ChangeLog: * objc-act.c: Moved to... * objc-act.cc: ...here. * objc-encoding.c: Moved to... * objc-encoding.cc: ...here. * objc-gnu-runtime-abi-01.c: Moved to... * objc-gnu-runtime-abi-01.cc: ...here. * objc-lang.c: Moved to... * objc-lang.cc: ...here. * objc-map.c: Moved to... * objc-map.cc: ...here. * objc-next-runtime-abi-01.c: Moved to... * objc-next-runtime-abi-01.cc: ...here. * objc-next-runtime-abi-02.c: Moved to... * objc-next-runtime-abi-02.cc: ...here. * objc-runtime-shared-support.c: Moved to... * objc-runtime-shared-support.cc: ...here. gcc/objcp/ChangeLog: * objcp-decl.c: Moved to... * objcp-decl.cc: ...here. * objcp-lang.c: Moved to... * objcp-lang.cc: ...here. libcpp/ChangeLog: * charset.c: Moved to... * charset.cc: ...here. * directives.c: Moved to... * directives.cc: ...here. * errors.c: Moved to... * errors.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * files.c: Moved to... * files.cc: ...here. * identifiers.c: Moved to... * identifiers.cc: ...here. * init.c: Moved to... * init.cc: ...here. * lex.c: Moved to... * lex.cc: ...here. * line-map.c: Moved to... * line-map.cc: ...here. * macro.c: Moved to... * macro.cc: ...here. * makeucnid.c: Moved to... * makeucnid.cc: ...here. * mkdeps.c: Moved to... * mkdeps.cc: ...here. * pch.c: Moved to... * pch.cc: ...here. * symtab.c: Moved to... * symtab.cc: ...here. * traditional.c: Moved to... * traditional.cc: ...here.
Diffstat (limited to 'gcc/fortran/expr.c')
-rw-r--r--gcc/fortran/expr.c6507
1 files changed, 0 insertions, 6507 deletions
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
deleted file mode 100644
index 20b88a8..0000000
--- a/gcc/fortran/expr.c
+++ /dev/null
@@ -1,6507 +0,0 @@
-/* Routines for manipulation of expression nodes.
- Copyright (C) 2000-2022 Free Software Foundation, Inc.
- Contributed by Andy Vaught
-
-This file is part of GCC.
-
-GCC is free software; you can redistribute it and/or modify it under
-the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 3, or (at your option) any later
-version.
-
-GCC is distributed in the hope that it will be useful, but WITHOUT ANY
-WARRANTY; without even the implied warranty of MERCHANTABILITY or
-FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
-for more details.
-
-You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING3. If not see
-<http://www.gnu.org/licenses/>. */
-
-#include "config.h"
-#include "system.h"
-#include "coretypes.h"
-#include "options.h"
-#include "gfortran.h"
-#include "arith.h"
-#include "match.h"
-#include "target-memory.h" /* for gfc_convert_boz */
-#include "constructor.h"
-#include "tree.h"
-
-
-/* The following set of functions provide access to gfc_expr* of
- various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.
-
- There are two functions available elsewhere that provide
- slightly different flavours of variables. Namely:
- expr.c (gfc_get_variable_expr)
- symbol.c (gfc_lval_expr_from_sym)
- TODO: Merge these functions, if possible. */
-
-/* Get a new expression node. */
-
-gfc_expr *
-gfc_get_expr (void)
-{
- gfc_expr *e;
-
- e = XCNEW (gfc_expr);
- gfc_clear_ts (&e->ts);
- e->shape = NULL;
- e->ref = NULL;
- e->symtree = NULL;
- return e;
-}
-
-
-/* Get a new expression node that is an array constructor
- of given type and kind. */
-
-gfc_expr *
-gfc_get_array_expr (bt type, int kind, locus *where)
-{
- gfc_expr *e;
-
- e = gfc_get_expr ();
- e->expr_type = EXPR_ARRAY;
- e->value.constructor = NULL;
- e->rank = 1;
- e->shape = NULL;
-
- e->ts.type = type;
- e->ts.kind = kind;
- if (where)
- e->where = *where;
-
- return e;
-}
-
-
-/* Get a new expression node that is the NULL expression. */
-
-gfc_expr *
-gfc_get_null_expr (locus *where)
-{
- gfc_expr *e;
-
- e = gfc_get_expr ();
- e->expr_type = EXPR_NULL;
- e->ts.type = BT_UNKNOWN;
-
- if (where)
- e->where = *where;
-
- return e;
-}
-
-
-/* Get a new expression node that is an operator expression node. */
-
-gfc_expr *
-gfc_get_operator_expr (locus *where, gfc_intrinsic_op op,
- gfc_expr *op1, gfc_expr *op2)
-{
- gfc_expr *e;
-
- e = gfc_get_expr ();
- e->expr_type = EXPR_OP;
- e->value.op.op = op;
- e->value.op.op1 = op1;
- e->value.op.op2 = op2;
-
- if (where)
- e->where = *where;
-
- return e;
-}
-
-
-/* Get a new expression node that is an structure constructor
- of given type and kind. */
-
-gfc_expr *
-gfc_get_structure_constructor_expr (bt type, int kind, locus *where)
-{
- gfc_expr *e;
-
- e = gfc_get_expr ();
- e->expr_type = EXPR_STRUCTURE;
- e->value.constructor = NULL;
-
- e->ts.type = type;
- e->ts.kind = kind;
- if (where)
- e->where = *where;
-
- return e;
-}
-
-
-/* Get a new expression node that is an constant of given type and kind. */
-
-gfc_expr *
-gfc_get_constant_expr (bt type, int kind, locus *where)
-{
- gfc_expr *e;
-
- if (!where)
- gfc_internal_error ("gfc_get_constant_expr(): locus %<where%> cannot be "
- "NULL");
-
- e = gfc_get_expr ();
-
- e->expr_type = EXPR_CONSTANT;
- e->ts.type = type;
- e->ts.kind = kind;
- e->where = *where;
-
- switch (type)
- {
- case BT_INTEGER:
- mpz_init (e->value.integer);
- break;
-
- case BT_REAL:
- gfc_set_model_kind (kind);
- mpfr_init (e->value.real);
- break;
-
- case BT_COMPLEX:
- gfc_set_model_kind (kind);
- mpc_init2 (e->value.complex, mpfr_get_default_prec());
- break;
-
- default:
- break;
- }
-
- return e;
-}
-
-
-/* Get a new expression node that is an string constant.
- If no string is passed, a string of len is allocated,
- blanked and null-terminated. */
-
-gfc_expr *
-gfc_get_character_expr (int kind, locus *where, const char *src, gfc_charlen_t len)
-{
- gfc_expr *e;
- gfc_char_t *dest;
-
- if (!src)
- {
- dest = gfc_get_wide_string (len + 1);
- gfc_wide_memset (dest, ' ', len);
- dest[len] = '\0';
- }
- else
- dest = gfc_char_to_widechar (src);
-
- e = gfc_get_constant_expr (BT_CHARACTER, kind,
- where ? where : &gfc_current_locus);
- e->value.character.string = dest;
- e->value.character.length = len;
-
- return e;
-}
-
-
-/* Get a new expression node that is an integer constant. */
-
-gfc_expr *
-gfc_get_int_expr (int kind, locus *where, HOST_WIDE_INT value)
-{
- gfc_expr *p;
- p = gfc_get_constant_expr (BT_INTEGER, kind,
- where ? where : &gfc_current_locus);
-
- const wide_int w = wi::shwi (value, kind * BITS_PER_UNIT);
- wi::to_mpz (w, p->value.integer, SIGNED);
-
- return p;
-}
-
-
-/* Get a new expression node that is a logical constant. */
-
-gfc_expr *
-gfc_get_logical_expr (int kind, locus *where, bool value)
-{
- gfc_expr *p;
- p = gfc_get_constant_expr (BT_LOGICAL, kind,
- where ? where : &gfc_current_locus);
-
- p->value.logical = value;
-
- return p;
-}
-
-
-gfc_expr *
-gfc_get_iokind_expr (locus *where, io_kind k)
-{
- gfc_expr *e;
-
- /* Set the types to something compatible with iokind. This is needed to
- get through gfc_free_expr later since iokind really has no Basic Type,
- BT, of its own. */
-
- e = gfc_get_expr ();
- e->expr_type = EXPR_CONSTANT;
- e->ts.type = BT_LOGICAL;
- e->value.iokind = k;
- e->where = *where;
-
- return e;
-}
-
-
-/* Given an expression pointer, return a copy of the expression. This
- subroutine is recursive. */
-
-gfc_expr *
-gfc_copy_expr (gfc_expr *p)
-{
- gfc_expr *q;
- gfc_char_t *s;
- char *c;
-
- if (p == NULL)
- return NULL;
-
- q = gfc_get_expr ();
- *q = *p;
-
- switch (q->expr_type)
- {
- case EXPR_SUBSTRING:
- s = gfc_get_wide_string (p->value.character.length + 1);
- q->value.character.string = s;
- memcpy (s, p->value.character.string,
- (p->value.character.length + 1) * sizeof (gfc_char_t));
- break;
-
- case EXPR_CONSTANT:
- /* Copy target representation, if it exists. */
- if (p->representation.string)
- {
- c = XCNEWVEC (char, p->representation.length + 1);
- q->representation.string = c;
- memcpy (c, p->representation.string, (p->representation.length + 1));
- }
-
- /* Copy the values of any pointer components of p->value. */
- switch (q->ts.type)
- {
- case BT_INTEGER:
- mpz_init_set (q->value.integer, p->value.integer);
- break;
-
- case BT_REAL:
- gfc_set_model_kind (q->ts.kind);
- mpfr_init (q->value.real);
- mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
- break;
-
- case BT_COMPLEX:
- gfc_set_model_kind (q->ts.kind);
- mpc_init2 (q->value.complex, mpfr_get_default_prec());
- mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE);
- break;
-
- case BT_CHARACTER:
- if (p->representation.string)
- q->value.character.string
- = gfc_char_to_widechar (q->representation.string);
- else
- {
- s = gfc_get_wide_string (p->value.character.length + 1);
- q->value.character.string = s;
-
- /* This is the case for the C_NULL_CHAR named constant. */
- if (p->value.character.length == 0
- && (p->ts.is_c_interop || p->ts.is_iso_c))
- {
- *s = '\0';
- /* Need to set the length to 1 to make sure the NUL
- terminator is copied. */
- q->value.character.length = 1;
- }
- else
- memcpy (s, p->value.character.string,
- (p->value.character.length + 1) * sizeof (gfc_char_t));
- }
- break;
-
- case BT_HOLLERITH:
- case BT_LOGICAL:
- case_bt_struct:
- case BT_CLASS:
- case BT_ASSUMED:
- break; /* Already done. */
-
- case BT_BOZ:
- q->boz.len = p->boz.len;
- q->boz.rdx = p->boz.rdx;
- q->boz.str = XCNEWVEC (char, q->boz.len + 1);
- strncpy (q->boz.str, p->boz.str, p->boz.len);
- break;
-
- case BT_PROCEDURE:
- case BT_VOID:
- /* Should never be reached. */
- case BT_UNKNOWN:
- gfc_internal_error ("gfc_copy_expr(): Bad expr node");
- /* Not reached. */
- }
-
- break;
-
- case EXPR_OP:
- switch (q->value.op.op)
- {
- case INTRINSIC_NOT:
- case INTRINSIC_PARENTHESES:
- case INTRINSIC_UPLUS:
- case INTRINSIC_UMINUS:
- q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
- break;
-
- default: /* Binary operators. */
- q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
- q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
- break;
- }
-
- break;
-
- case EXPR_FUNCTION:
- q->value.function.actual =
- gfc_copy_actual_arglist (p->value.function.actual);
- break;
-
- case EXPR_COMPCALL:
- case EXPR_PPC:
- q->value.compcall.actual =
- gfc_copy_actual_arglist (p->value.compcall.actual);
- q->value.compcall.tbp = p->value.compcall.tbp;
- break;
-
- case EXPR_STRUCTURE:
- case EXPR_ARRAY:
- q->value.constructor = gfc_constructor_copy (p->value.constructor);
- break;
-
- case EXPR_VARIABLE:
- case EXPR_NULL:
- break;
-
- case EXPR_UNKNOWN:
- gcc_unreachable ();
- }
-
- q->shape = gfc_copy_shape (p->shape, p->rank);
-
- q->ref = gfc_copy_ref (p->ref);
-
- if (p->param_list)
- q->param_list = gfc_copy_actual_arglist (p->param_list);
-
- return q;
-}
-
-
-void
-gfc_clear_shape (mpz_t *shape, int rank)
-{
- int i;
-
- for (i = 0; i < rank; i++)
- mpz_clear (shape[i]);
-}
-
-
-void
-gfc_free_shape (mpz_t **shape, int rank)
-{
- if (*shape == NULL)
- return;
-
- gfc_clear_shape (*shape, rank);
- free (*shape);
- *shape = NULL;
-}
-
-
-/* Workhorse function for gfc_free_expr() that frees everything
- beneath an expression node, but not the node itself. This is
- useful when we want to simplify a node and replace it with
- something else or the expression node belongs to another structure. */
-
-static void
-free_expr0 (gfc_expr *e)
-{
- switch (e->expr_type)
- {
- case EXPR_CONSTANT:
- /* Free any parts of the value that need freeing. */
- switch (e->ts.type)
- {
- case BT_INTEGER:
- mpz_clear (e->value.integer);
- break;
-
- case BT_REAL:
- mpfr_clear (e->value.real);
- break;
-
- case BT_CHARACTER:
- free (e->value.character.string);
- break;
-
- case BT_COMPLEX:
- mpc_clear (e->value.complex);
- break;
-
- default:
- break;
- }
-
- /* Free the representation. */
- free (e->representation.string);
-
- break;
-
- case EXPR_OP:
- if (e->value.op.op1 != NULL)
- gfc_free_expr (e->value.op.op1);
- if (e->value.op.op2 != NULL)
- gfc_free_expr (e->value.op.op2);
- break;
-
- case EXPR_FUNCTION:
- gfc_free_actual_arglist (e->value.function.actual);
- break;
-
- case EXPR_COMPCALL:
- case EXPR_PPC:
- gfc_free_actual_arglist (e->value.compcall.actual);
- break;
-
- case EXPR_VARIABLE:
- break;
-
- case EXPR_ARRAY:
- case EXPR_STRUCTURE:
- gfc_constructor_free (e->value.constructor);
- break;
-
- case EXPR_SUBSTRING:
- free (e->value.character.string);
- break;
-
- case EXPR_NULL:
- break;
-
- default:
- gfc_internal_error ("free_expr0(): Bad expr type");
- }
-
- /* Free a shape array. */
- gfc_free_shape (&e->shape, e->rank);
-
- gfc_free_ref_list (e->ref);
-
- gfc_free_actual_arglist (e->param_list);
-
- memset (e, '\0', sizeof (gfc_expr));
-}
-
-
-/* Free an expression node and everything beneath it. */
-
-void
-gfc_free_expr (gfc_expr *e)
-{
- if (e == NULL)
- return;
- free_expr0 (e);
- free (e);
-}
-
-
-/* Free an argument list and everything below it. */
-
-void
-gfc_free_actual_arglist (gfc_actual_arglist *a1)
-{
- gfc_actual_arglist *a2;
-
- while (a1)
- {
- a2 = a1->next;
- if (a1->expr)
- gfc_free_expr (a1->expr);
- free (a1);
- a1 = a2;
- }
-}
-
-
-/* Copy an arglist structure and all of the arguments. */
-
-gfc_actual_arglist *
-gfc_copy_actual_arglist (gfc_actual_arglist *p)
-{
- gfc_actual_arglist *head, *tail, *new_arg;
-
- head = tail = NULL;
-
- for (; p; p = p->next)
- {
- new_arg = gfc_get_actual_arglist ();
- *new_arg = *p;
-
- new_arg->expr = gfc_copy_expr (p->expr);
- new_arg->next = NULL;
-
- if (head == NULL)
- head = new_arg;
- else
- tail->next = new_arg;
-
- tail = new_arg;
- }
-
- return head;
-}
-
-
-/* Free a list of reference structures. */
-
-void
-gfc_free_ref_list (gfc_ref *p)
-{
- gfc_ref *q;
- int i;
-
- for (; p; p = q)
- {
- q = p->next;
-
- switch (p->type)
- {
- case REF_ARRAY:
- for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
- {
- gfc_free_expr (p->u.ar.start[i]);
- gfc_free_expr (p->u.ar.end[i]);
- gfc_free_expr (p->u.ar.stride[i]);
- }
-
- break;
-
- case REF_SUBSTRING:
- gfc_free_expr (p->u.ss.start);
- gfc_free_expr (p->u.ss.end);
- break;
-
- case REF_COMPONENT:
- case REF_INQUIRY:
- break;
- }
-
- free (p);
- }
-}
-
-
-/* Graft the *src expression onto the *dest subexpression. */
-
-void
-gfc_replace_expr (gfc_expr *dest, gfc_expr *src)
-{
- free_expr0 (dest);
- *dest = *src;
- free (src);
-}
-
-
-/* Try to extract an integer constant from the passed expression node.
- Return true if some error occurred, false on success. If REPORT_ERROR
- is non-zero, emit error, for positive REPORT_ERROR using gfc_error,
- for negative using gfc_error_now. */
-
-bool
-gfc_extract_int (gfc_expr *expr, int *result, int report_error)
-{
- gfc_ref *ref;
-
- /* A KIND component is a parameter too. The expression for it
- is stored in the initializer and should be consistent with
- the tests below. */
- if (gfc_expr_attr(expr).pdt_kind)
- {
- for (ref = expr->ref; ref; ref = ref->next)
- {
- if (ref->u.c.component->attr.pdt_kind)
- expr = ref->u.c.component->initializer;
- }
- }
-
- if (expr->expr_type != EXPR_CONSTANT)
- {
- if (report_error > 0)
- gfc_error ("Constant expression required at %C");
- else if (report_error < 0)
- gfc_error_now ("Constant expression required at %C");
- return true;
- }
-
- if (expr->ts.type != BT_INTEGER)
- {
- if (report_error > 0)
- gfc_error ("Integer expression required at %C");
- else if (report_error < 0)
- gfc_error_now ("Integer expression required at %C");
- return true;
- }
-
- if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
- || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
- {
- if (report_error > 0)
- gfc_error ("Integer value too large in expression at %C");
- else if (report_error < 0)
- gfc_error_now ("Integer value too large in expression at %C");
- return true;
- }
-
- *result = (int) mpz_get_si (expr->value.integer);
-
- return false;
-}
-
-
-/* Same as gfc_extract_int, but use a HWI. */
-
-bool
-gfc_extract_hwi (gfc_expr *expr, HOST_WIDE_INT *result, int report_error)
-{
- gfc_ref *ref;
-
- /* A KIND component is a parameter too. The expression for it is
- stored in the initializer and should be consistent with the tests
- below. */
- if (gfc_expr_attr(expr).pdt_kind)
- {
- for (ref = expr->ref; ref; ref = ref->next)
- {
- if (ref->u.c.component->attr.pdt_kind)
- expr = ref->u.c.component->initializer;
- }
- }
-
- if (expr->expr_type != EXPR_CONSTANT)
- {
- if (report_error > 0)
- gfc_error ("Constant expression required at %C");
- else if (report_error < 0)
- gfc_error_now ("Constant expression required at %C");
- return true;
- }
-
- if (expr->ts.type != BT_INTEGER)
- {
- if (report_error > 0)
- gfc_error ("Integer expression required at %C");
- else if (report_error < 0)
- gfc_error_now ("Integer expression required at %C");
- return true;
- }
-
- /* Use long_long_integer_type_node to determine when to saturate. */
- const wide_int val = wi::from_mpz (long_long_integer_type_node,
- expr->value.integer, false);
-
- if (!wi::fits_shwi_p (val))
- {
- if (report_error > 0)
- gfc_error ("Integer value too large in expression at %C");
- else if (report_error < 0)
- gfc_error_now ("Integer value too large in expression at %C");
- return true;
- }
-
- *result = val.to_shwi ();
-
- return false;
-}
-
-
-/* Recursively copy a list of reference structures. */
-
-gfc_ref *
-gfc_copy_ref (gfc_ref *src)
-{
- gfc_array_ref *ar;
- gfc_ref *dest;
-
- if (src == NULL)
- return NULL;
-
- dest = gfc_get_ref ();
- dest->type = src->type;
-
- switch (src->type)
- {
- case REF_ARRAY:
- ar = gfc_copy_array_ref (&src->u.ar);
- dest->u.ar = *ar;
- free (ar);
- break;
-
- case REF_COMPONENT:
- dest->u.c = src->u.c;
- break;
-
- case REF_INQUIRY:
- dest->u.i = src->u.i;
- break;
-
- case REF_SUBSTRING:
- dest->u.ss = src->u.ss;
- dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
- dest->u.ss.end = gfc_copy_expr (src->u.ss.end);
- break;
- }
-
- dest->next = gfc_copy_ref (src->next);
-
- return dest;
-}
-
-
-/* Detect whether an expression has any vector index array references. */
-
-int
-gfc_has_vector_index (gfc_expr *e)
-{
- gfc_ref *ref;
- int i;
- for (ref = e->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY)
- for (i = 0; i < ref->u.ar.dimen; i++)
- if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
- return 1;
- return 0;
-}
-
-
-/* Copy a shape array. */
-
-mpz_t *
-gfc_copy_shape (mpz_t *shape, int rank)
-{
- mpz_t *new_shape;
- int n;
-
- if (shape == NULL)
- return NULL;
-
- new_shape = gfc_get_shape (rank);
-
- for (n = 0; n < rank; n++)
- mpz_init_set (new_shape[n], shape[n]);
-
- return new_shape;
-}
-
-
-/* Copy a shape array excluding dimension N, where N is an integer
- constant expression. Dimensions are numbered in Fortran style --
- starting with ONE.
-
- So, if the original shape array contains R elements
- { s1 ... sN-1 sN sN+1 ... sR-1 sR}
- the result contains R-1 elements:
- { s1 ... sN-1 sN+1 ... sR-1}
-
- If anything goes wrong -- N is not a constant, its value is out
- of range -- or anything else, just returns NULL. */
-
-mpz_t *
-gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
-{
- mpz_t *new_shape, *s;
- int i, n;
-
- if (shape == NULL
- || rank <= 1
- || dim == NULL
- || dim->expr_type != EXPR_CONSTANT
- || dim->ts.type != BT_INTEGER)
- return NULL;
-
- n = mpz_get_si (dim->value.integer);
- n--; /* Convert to zero based index. */
- if (n < 0 || n >= rank)
- return NULL;
-
- s = new_shape = gfc_get_shape (rank - 1);
-
- for (i = 0; i < rank; i++)
- {
- if (i == n)
- continue;
- mpz_init_set (*s, shape[i]);
- s++;
- }
-
- return new_shape;
-}
-
-
-/* Return the maximum kind of two expressions. In general, higher
- kind numbers mean more precision for numeric types. */
-
-int
-gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
-{
- return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
-}
-
-
-/* Returns nonzero if the type is numeric, zero otherwise. */
-
-static int
-numeric_type (bt type)
-{
- return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
-}
-
-
-/* Returns nonzero if the typespec is a numeric type, zero otherwise. */
-
-int
-gfc_numeric_ts (gfc_typespec *ts)
-{
- return numeric_type (ts->type);
-}
-
-
-/* Return an expression node with an optional argument list attached.
- A variable number of gfc_expr pointers are strung together in an
- argument list with a NULL pointer terminating the list. */
-
-gfc_expr *
-gfc_build_conversion (gfc_expr *e)
-{
- gfc_expr *p;
-
- p = gfc_get_expr ();
- p->expr_type = EXPR_FUNCTION;
- p->symtree = NULL;
- p->value.function.actual = gfc_get_actual_arglist ();
- p->value.function.actual->expr = e;
-
- return p;
-}
-
-
-/* Given an expression node with some sort of numeric binary
- expression, insert type conversions required to make the operands
- have the same type. Conversion warnings are disabled if wconversion
- is set to 0.
-
- The exception is that the operands of an exponential don't have to
- have the same type. If possible, the base is promoted to the type
- of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
- 1.0**2 stays as it is. */
-
-void
-gfc_type_convert_binary (gfc_expr *e, int wconversion)
-{
- gfc_expr *op1, *op2;
-
- op1 = e->value.op.op1;
- op2 = e->value.op.op2;
-
- if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
- {
- gfc_clear_ts (&e->ts);
- return;
- }
-
- /* Kind conversions of same type. */
- if (op1->ts.type == op2->ts.type)
- {
- if (op1->ts.kind == op2->ts.kind)
- {
- /* No type conversions. */
- e->ts = op1->ts;
- goto done;
- }
-
- if (op1->ts.kind > op2->ts.kind)
- gfc_convert_type_warn (op2, &op1->ts, 2, wconversion);
- else
- gfc_convert_type_warn (op1, &op2->ts, 2, wconversion);
-
- e->ts = op1->ts;
- goto done;
- }
-
- /* Integer combined with real or complex. */
- if (op2->ts.type == BT_INTEGER)
- {
- e->ts = op1->ts;
-
- /* Special case for ** operator. */
- if (e->value.op.op == INTRINSIC_POWER)
- goto done;
-
- gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
- goto done;
- }
-
- if (op1->ts.type == BT_INTEGER)
- {
- e->ts = op2->ts;
- gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
- goto done;
- }
-
- /* Real combined with complex. */
- e->ts.type = BT_COMPLEX;
- if (op1->ts.kind > op2->ts.kind)
- e->ts.kind = op1->ts.kind;
- else
- e->ts.kind = op2->ts.kind;
- if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
- gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
- if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
- gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
-
-done:
- return;
-}
-
-
-/* Standard intrinsics listed under F2018:10.1.12 (6), which are excluded in
- constant expressions, except TRANSFER (c.f. item (8)), which would need
- separate treatment. */
-
-static bool
-is_non_constant_intrinsic (gfc_expr *e)
-{
- if (e->expr_type == EXPR_FUNCTION
- && e->value.function.isym)
- {
- switch (e->value.function.isym->id)
- {
- case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
- case GFC_ISYM_GET_TEAM:
- case GFC_ISYM_NULL:
- case GFC_ISYM_NUM_IMAGES:
- case GFC_ISYM_TEAM_NUMBER:
- case GFC_ISYM_THIS_IMAGE:
- return true;
-
- default:
- return false;
- }
- }
- return false;
-}
-
-
-/* Determine if an expression is constant in the sense of F08:7.1.12.
- * This function expects that the expression has already been simplified. */
-
-bool
-gfc_is_constant_expr (gfc_expr *e)
-{
- gfc_constructor *c;
- gfc_actual_arglist *arg;
-
- if (e == NULL)
- return true;
-
- switch (e->expr_type)
- {
- case EXPR_OP:
- return (gfc_is_constant_expr (e->value.op.op1)
- && (e->value.op.op2 == NULL
- || gfc_is_constant_expr (e->value.op.op2)));
-
- case EXPR_VARIABLE:
- /* The only context in which this can occur is in a parameterized
- derived type declaration, so returning true is OK. */
- if (e->symtree->n.sym->attr.pdt_len
- || e->symtree->n.sym->attr.pdt_kind)
- return true;
- return false;
-
- case EXPR_FUNCTION:
- case EXPR_PPC:
- case EXPR_COMPCALL:
- gcc_assert (e->symtree || e->value.function.esym
- || e->value.function.isym);
-
- /* Check for intrinsics excluded in constant expressions. */
- if (e->value.function.isym && is_non_constant_intrinsic (e))
- return false;
-
- /* Call to intrinsic with at least one argument. */
- if (e->value.function.isym && e->value.function.actual)
- {
- for (arg = e->value.function.actual; arg; arg = arg->next)
- if (!gfc_is_constant_expr (arg->expr))
- return false;
- }
-
- if (e->value.function.isym
- && (e->value.function.isym->elemental
- || e->value.function.isym->pure
- || e->value.function.isym->inquiry
- || e->value.function.isym->transformational))
- return true;
-
- return false;
-
- case EXPR_CONSTANT:
- case EXPR_NULL:
- return true;
-
- case EXPR_SUBSTRING:
- return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
- && gfc_is_constant_expr (e->ref->u.ss.end));
-
- case EXPR_ARRAY:
- case EXPR_STRUCTURE:
- c = gfc_constructor_first (e->value.constructor);
- if ((e->expr_type == EXPR_ARRAY) && c && c->iterator)
- return gfc_constant_ac (e);
-
- for (; c; c = gfc_constructor_next (c))
- if (!gfc_is_constant_expr (c->expr))
- return false;
-
- return true;
-
-
- default:
- gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
- return false;
- }
-}
-
-
-/* Is true if the expression or symbol is a passed CFI descriptor. */
-bool
-is_CFI_desc (gfc_symbol *sym, gfc_expr *e)
-{
- if (sym == NULL
- && e && e->expr_type == EXPR_VARIABLE)
- sym = e->symtree->n.sym;
-
- if (sym && sym->attr.dummy
- && sym->ns->proc_name->attr.is_bind_c
- && (sym->attr.pointer
- || sym->attr.allocatable
- || (sym->attr.dimension
- && (sym->as->type == AS_ASSUMED_SHAPE
- || sym->as->type == AS_ASSUMED_RANK))
- || (sym->ts.type == BT_CHARACTER
- && (!sym->ts.u.cl || !sym->ts.u.cl->length))))
- return true;
-
-return false;
-}
-
-
-/* Is true if an array reference is followed by a component or substring
- reference. */
-bool
-is_subref_array (gfc_expr * e)
-{
- gfc_ref * ref;
- bool seen_array;
- gfc_symbol *sym;
-
- if (e->expr_type != EXPR_VARIABLE)
- return false;
-
- sym = e->symtree->n.sym;
-
- if (sym->attr.subref_array_pointer)
- return true;
-
- seen_array = false;
-
- for (ref = e->ref; ref; ref = ref->next)
- {
- /* If we haven't seen the array reference and this is an intrinsic,
- what follows cannot be a subreference array, unless there is a
- substring reference. */
- if (!seen_array && ref->type == REF_COMPONENT
- && ref->u.c.component->ts.type != BT_CHARACTER
- && ref->u.c.component->ts.type != BT_CLASS
- && !gfc_bt_struct (ref->u.c.component->ts.type))
- return false;
-
- if (ref->type == REF_ARRAY
- && ref->u.ar.type != AR_ELEMENT)
- seen_array = true;
-
- if (seen_array
- && ref->type != REF_ARRAY)
- return seen_array;
- }
-
- if (sym->ts.type == BT_CLASS
- && sym->attr.dummy
- && CLASS_DATA (sym)->attr.dimension
- && CLASS_DATA (sym)->attr.class_pointer)
- return true;
-
- return false;
-}
-
-
-/* Try to collapse intrinsic expressions. */
-
-static bool
-simplify_intrinsic_op (gfc_expr *p, int type)
-{
- gfc_intrinsic_op op;
- gfc_expr *op1, *op2, *result;
-
- if (p->value.op.op == INTRINSIC_USER)
- return true;
-
- op1 = p->value.op.op1;
- op2 = p->value.op.op2;
- op = p->value.op.op;
-
- if (!gfc_simplify_expr (op1, type))
- return false;
- if (!gfc_simplify_expr (op2, type))
- return false;
-
- if (!gfc_is_constant_expr (op1)
- || (op2 != NULL && !gfc_is_constant_expr (op2)))
- return true;
-
- /* Rip p apart. */
- p->value.op.op1 = NULL;
- p->value.op.op2 = NULL;
-
- switch (op)
- {
- case INTRINSIC_PARENTHESES:
- result = gfc_parentheses (op1);
- break;
-
- case INTRINSIC_UPLUS:
- result = gfc_uplus (op1);
- break;
-
- case INTRINSIC_UMINUS:
- result = gfc_uminus (op1);
- break;
-
- case INTRINSIC_PLUS:
- result = gfc_add (op1, op2);
- break;
-
- case INTRINSIC_MINUS:
- result = gfc_subtract (op1, op2);
- break;
-
- case INTRINSIC_TIMES:
- result = gfc_multiply (op1, op2);
- break;
-
- case INTRINSIC_DIVIDE:
- result = gfc_divide (op1, op2);
- break;
-
- case INTRINSIC_POWER:
- result = gfc_power (op1, op2);
- break;
-
- case INTRINSIC_CONCAT:
- result = gfc_concat (op1, op2);
- break;
-
- case INTRINSIC_EQ:
- case INTRINSIC_EQ_OS:
- result = gfc_eq (op1, op2, op);
- break;
-
- case INTRINSIC_NE:
- case INTRINSIC_NE_OS:
- result = gfc_ne (op1, op2, op);
- break;
-
- case INTRINSIC_GT:
- case INTRINSIC_GT_OS:
- result = gfc_gt (op1, op2, op);
- break;
-
- case INTRINSIC_GE:
- case INTRINSIC_GE_OS:
- result = gfc_ge (op1, op2, op);
- break;
-
- case INTRINSIC_LT:
- case INTRINSIC_LT_OS:
- result = gfc_lt (op1, op2, op);
- break;
-
- case INTRINSIC_LE:
- case INTRINSIC_LE_OS:
- result = gfc_le (op1, op2, op);
- break;
-
- case INTRINSIC_NOT:
- result = gfc_not (op1);
- break;
-
- case INTRINSIC_AND:
- result = gfc_and (op1, op2);
- break;
-
- case INTRINSIC_OR:
- result = gfc_or (op1, op2);
- break;
-
- case INTRINSIC_EQV:
- result = gfc_eqv (op1, op2);
- break;
-
- case INTRINSIC_NEQV:
- result = gfc_neqv (op1, op2);
- break;
-
- default:
- gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
- }
-
- if (result == NULL)
- {
- gfc_free_expr (op1);
- gfc_free_expr (op2);
- return false;
- }
-
- result->rank = p->rank;
- result->where = p->where;
- gfc_replace_expr (p, result);
-
- return true;
-}
-
-
-/* Subroutine to simplify constructor expressions. Mutually recursive
- with gfc_simplify_expr(). */
-
-static bool
-simplify_constructor (gfc_constructor_base base, int type)
-{
- gfc_constructor *c;
- gfc_expr *p;
-
- for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
- {
- if (c->iterator
- && (!gfc_simplify_expr(c->iterator->start, type)
- || !gfc_simplify_expr (c->iterator->end, type)
- || !gfc_simplify_expr (c->iterator->step, type)))
- return false;
-
- if (c->expr)
- {
- /* Try and simplify a copy. Replace the original if successful
- but keep going through the constructor at all costs. Not
- doing so can make a dog's dinner of complicated things. */
- p = gfc_copy_expr (c->expr);
-
- if (!gfc_simplify_expr (p, type))
- {
- gfc_free_expr (p);
- continue;
- }
-
- gfc_replace_expr (c->expr, p);
- }
- }
-
- return true;
-}
-
-
-/* Pull a single array element out of an array constructor. */
-
-static bool
-find_array_element (gfc_constructor_base base, gfc_array_ref *ar,
- gfc_constructor **rval)
-{
- unsigned long nelemen;
- int i;
- mpz_t delta;
- mpz_t offset;
- mpz_t span;
- mpz_t tmp;
- gfc_constructor *cons;
- gfc_expr *e;
- bool t;
-
- t = true;
- e = NULL;
-
- mpz_init_set_ui (offset, 0);
- mpz_init (delta);
- mpz_init (tmp);
- mpz_init_set_ui (span, 1);
- for (i = 0; i < ar->dimen; i++)
- {
- if (!gfc_reduce_init_expr (ar->as->lower[i])
- || !gfc_reduce_init_expr (ar->as->upper[i])
- || ar->as->upper[i]->expr_type != EXPR_CONSTANT
- || ar->as->lower[i]->expr_type != EXPR_CONSTANT)
- {
- t = false;
- cons = NULL;
- goto depart;
- }
-
- e = ar->start[i];
- if (e->expr_type != EXPR_CONSTANT)
- {
- cons = NULL;
- goto depart;
- }
-
- /* Check the bounds. */
- if ((ar->as->upper[i]
- && mpz_cmp (e->value.integer,
- ar->as->upper[i]->value.integer) > 0)
- || (mpz_cmp (e->value.integer,
- ar->as->lower[i]->value.integer) < 0))
- {
- gfc_error ("Index in dimension %d is out of bounds "
- "at %L", i + 1, &ar->c_where[i]);
- cons = NULL;
- t = false;
- goto depart;
- }
-
- mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
- mpz_mul (delta, delta, span);
- mpz_add (offset, offset, delta);
-
- mpz_set_ui (tmp, 1);
- mpz_add (tmp, tmp, ar->as->upper[i]->value.integer);
- mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
- mpz_mul (span, span, tmp);
- }
-
- for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui (offset);
- cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--)
- {
- if (cons->iterator)
- {
- cons = NULL;
- goto depart;
- }
- }
-
-depart:
- mpz_clear (delta);
- mpz_clear (offset);
- mpz_clear (span);
- mpz_clear (tmp);
- *rval = cons;
- return t;
-}
-
-
-/* Find a component of a structure constructor. */
-
-static gfc_constructor *
-find_component_ref (gfc_constructor_base base, gfc_ref *ref)
-{
- gfc_component *pick = ref->u.c.component;
- gfc_constructor *c = gfc_constructor_first (base);
-
- gfc_symbol *dt = ref->u.c.sym;
- int ext = dt->attr.extension;
-
- /* For extended types, check if the desired component is in one of the
- * parent types. */
- while (ext > 0 && gfc_find_component (dt->components->ts.u.derived,
- pick->name, true, true, NULL))
- {
- dt = dt->components->ts.u.derived;
- c = gfc_constructor_first (c->expr->value.constructor);
- ext--;
- }
-
- gfc_component *comp = dt->components;
- while (comp != pick)
- {
- comp = comp->next;
- c = gfc_constructor_next (c);
- }
-
- return c;
-}
-
-
-/* Replace an expression with the contents of a constructor, removing
- the subobject reference in the process. */
-
-static void
-remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
-{
- gfc_expr *e;
-
- if (cons)
- {
- e = cons->expr;
- cons->expr = NULL;
- }
- else
- e = gfc_copy_expr (p);
- e->ref = p->ref->next;
- p->ref->next = NULL;
- gfc_replace_expr (p, e);
-}
-
-
-/* Pull an array section out of an array constructor. */
-
-static bool
-find_array_section (gfc_expr *expr, gfc_ref *ref)
-{
- int idx;
- int rank;
- int d;
- int shape_i;
- int limit;
- long unsigned one = 1;
- bool incr_ctr;
- mpz_t start[GFC_MAX_DIMENSIONS];
- mpz_t end[GFC_MAX_DIMENSIONS];
- mpz_t stride[GFC_MAX_DIMENSIONS];
- mpz_t delta[GFC_MAX_DIMENSIONS];
- mpz_t ctr[GFC_MAX_DIMENSIONS];
- mpz_t delta_mpz;
- mpz_t tmp_mpz;
- mpz_t nelts;
- mpz_t ptr;
- gfc_constructor_base base;
- gfc_constructor *cons, *vecsub[GFC_MAX_DIMENSIONS];
- gfc_expr *begin;
- gfc_expr *finish;
- gfc_expr *step;
- gfc_expr *upper;
- gfc_expr *lower;
- bool t;
-
- t = true;
-
- base = expr->value.constructor;
- expr->value.constructor = NULL;
-
- rank = ref->u.ar.as->rank;
-
- if (expr->shape == NULL)
- expr->shape = gfc_get_shape (rank);
-
- mpz_init_set_ui (delta_mpz, one);
- mpz_init_set_ui (nelts, one);
- mpz_init (tmp_mpz);
-
- /* Do the initialization now, so that we can cleanup without
- keeping track of where we were. */
- for (d = 0; d < rank; d++)
- {
- mpz_init (delta[d]);
- mpz_init (start[d]);
- mpz_init (end[d]);
- mpz_init (ctr[d]);
- mpz_init (stride[d]);
- vecsub[d] = NULL;
- }
-
- /* Build the counters to clock through the array reference. */
- shape_i = 0;
- for (d = 0; d < rank; d++)
- {
- /* Make this stretch of code easier on the eye! */
- begin = ref->u.ar.start[d];
- finish = ref->u.ar.end[d];
- step = ref->u.ar.stride[d];
- lower = ref->u.ar.as->lower[d];
- upper = ref->u.ar.as->upper[d];
-
- if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
- {
- gfc_constructor *ci;
- gcc_assert (begin);
-
- if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
- {
- t = false;
- goto cleanup;
- }
-
- gcc_assert (begin->rank == 1);
- /* Zero-sized arrays have no shape and no elements, stop early. */
- if (!begin->shape)
- {
- mpz_init_set_ui (nelts, 0);
- break;
- }
-
- vecsub[d] = gfc_constructor_first (begin->value.constructor);
- mpz_set (ctr[d], vecsub[d]->expr->value.integer);
- mpz_mul (nelts, nelts, begin->shape[0]);
- mpz_set (expr->shape[shape_i++], begin->shape[0]);
-
- /* Check bounds. */
- for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci))
- {
- if (mpz_cmp (ci->expr->value.integer, upper->value.integer) > 0
- || mpz_cmp (ci->expr->value.integer,
- lower->value.integer) < 0)
- {
- gfc_error ("index in dimension %d is out of bounds "
- "at %L", d + 1, &ref->u.ar.c_where[d]);
- t = false;
- goto cleanup;
- }
- }
- }
- else
- {
- if ((begin && begin->expr_type != EXPR_CONSTANT)
- || (finish && finish->expr_type != EXPR_CONSTANT)
- || (step && step->expr_type != EXPR_CONSTANT))
- {
- t = false;
- goto cleanup;
- }
-
- /* Obtain the stride. */
- if (step)
- mpz_set (stride[d], step->value.integer);
- else
- mpz_set_ui (stride[d], one);
-
- if (mpz_cmp_ui (stride[d], 0) == 0)
- mpz_set_ui (stride[d], one);
-
- /* Obtain the start value for the index. */
- if (begin)
- mpz_set (start[d], begin->value.integer);
- else
- mpz_set (start[d], lower->value.integer);
-
- mpz_set (ctr[d], start[d]);
-
- /* Obtain the end value for the index. */
- if (finish)
- mpz_set (end[d], finish->value.integer);
- else
- mpz_set (end[d], upper->value.integer);
-
- /* Separate 'if' because elements sometimes arrive with
- non-null end. */
- if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
- mpz_set (end [d], begin->value.integer);
-
- /* Check the bounds. */
- if (mpz_cmp (ctr[d], upper->value.integer) > 0
- || mpz_cmp (end[d], upper->value.integer) > 0
- || mpz_cmp (ctr[d], lower->value.integer) < 0
- || mpz_cmp (end[d], lower->value.integer) < 0)
- {
- gfc_error ("index in dimension %d is out of bounds "
- "at %L", d + 1, &ref->u.ar.c_where[d]);
- t = false;
- goto cleanup;
- }
-
- /* Calculate the number of elements and the shape. */
- mpz_set (tmp_mpz, stride[d]);
- mpz_add (tmp_mpz, end[d], tmp_mpz);
- mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
- mpz_div (tmp_mpz, tmp_mpz, stride[d]);
- mpz_mul (nelts, nelts, tmp_mpz);
-
- /* An element reference reduces the rank of the expression; don't
- add anything to the shape array. */
- if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
- mpz_set (expr->shape[shape_i++], tmp_mpz);
- }
-
- /* Calculate the 'stride' (=delta) for conversion of the
- counter values into the index along the constructor. */
- mpz_set (delta[d], delta_mpz);
- mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
- mpz_add_ui (tmp_mpz, tmp_mpz, one);
- mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
- }
-
- mpz_init (ptr);
- cons = gfc_constructor_first (base);
-
- /* Now clock through the array reference, calculating the index in
- the source constructor and transferring the elements to the new
- constructor. */
- for (idx = 0; idx < (int) mpz_get_si (nelts); idx++)
- {
- mpz_init_set_ui (ptr, 0);
-
- incr_ctr = true;
- for (d = 0; d < rank; d++)
- {
- mpz_set (tmp_mpz, ctr[d]);
- mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
- mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
- mpz_add (ptr, ptr, tmp_mpz);
-
- if (!incr_ctr) continue;
-
- if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
- {
- gcc_assert(vecsub[d]);
-
- if (!gfc_constructor_next (vecsub[d]))
- vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor);
- else
- {
- vecsub[d] = gfc_constructor_next (vecsub[d]);
- incr_ctr = false;
- }
- mpz_set (ctr[d], vecsub[d]->expr->value.integer);
- }
- else
- {
- mpz_add (ctr[d], ctr[d], stride[d]);
-
- if (mpz_cmp_ui (stride[d], 0) > 0
- ? mpz_cmp (ctr[d], end[d]) > 0
- : mpz_cmp (ctr[d], end[d]) < 0)
- mpz_set (ctr[d], start[d]);
- else
- incr_ctr = false;
- }
- }
-
- limit = mpz_get_ui (ptr);
- if (limit >= flag_max_array_constructor)
- {
- gfc_error ("The number of elements in the array constructor "
- "at %L requires an increase of the allowed %d "
- "upper limit. See %<-fmax-array-constructor%> "
- "option", &expr->where, flag_max_array_constructor);
- return false;
- }
-
- cons = gfc_constructor_lookup (base, limit);
- gcc_assert (cons);
- gfc_constructor_append_expr (&expr->value.constructor,
- gfc_copy_expr (cons->expr), NULL);
- }
-
- mpz_clear (ptr);
-
-cleanup:
-
- mpz_clear (delta_mpz);
- mpz_clear (tmp_mpz);
- mpz_clear (nelts);
- for (d = 0; d < rank; d++)
- {
- mpz_clear (delta[d]);
- mpz_clear (start[d]);
- mpz_clear (end[d]);
- mpz_clear (ctr[d]);
- mpz_clear (stride[d]);
- }
- gfc_constructor_free (base);
- return t;
-}
-
-/* Pull a substring out of an expression. */
-
-static bool
-find_substring_ref (gfc_expr *p, gfc_expr **newp)
-{
- gfc_charlen_t end;
- gfc_charlen_t start;
- gfc_charlen_t length;
- gfc_char_t *chr;
-
- if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
- || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
- return false;
-
- *newp = gfc_copy_expr (p);
- free ((*newp)->value.character.string);
-
- end = (gfc_charlen_t) mpz_get_si (p->ref->u.ss.end->value.integer);
- start = (gfc_charlen_t) mpz_get_si (p->ref->u.ss.start->value.integer);
- if (end >= start)
- length = end - start + 1;
- else
- length = 0;
-
- chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1);
- (*newp)->value.character.length = length;
- memcpy (chr, &p->value.character.string[start - 1],
- length * sizeof (gfc_char_t));
- chr[length] = '\0';
- return true;
-}
-
-
-/* Pull an inquiry result out of an expression. */
-
-static bool
-find_inquiry_ref (gfc_expr *p, gfc_expr **newp)
-{
- gfc_ref *ref;
- gfc_ref *inquiry = NULL;
- gfc_expr *tmp;
-
- tmp = gfc_copy_expr (p);
-
- if (tmp->ref && tmp->ref->type == REF_INQUIRY)
- {
- inquiry = tmp->ref;
- tmp->ref = NULL;
- }
- else
- {
- for (ref = tmp->ref; ref; ref = ref->next)
- if (ref->next && ref->next->type == REF_INQUIRY)
- {
- inquiry = ref->next;
- ref->next = NULL;
- }
- }
-
- if (!inquiry)
- {
- gfc_free_expr (tmp);
- return false;
- }
-
- gfc_resolve_expr (tmp);
-
- /* In principle there can be more than one inquiry reference. */
- for (; inquiry; inquiry = inquiry->next)
- {
- switch (inquiry->u.i)
- {
- case INQUIRY_LEN:
- if (tmp->ts.type != BT_CHARACTER)
- goto cleanup;
-
- if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C"))
- goto cleanup;
-
- if (tmp->ts.u.cl->length
- && tmp->ts.u.cl->length->expr_type == EXPR_CONSTANT)
- *newp = gfc_copy_expr (tmp->ts.u.cl->length);
- else if (tmp->expr_type == EXPR_CONSTANT)
- *newp = gfc_get_int_expr (gfc_default_integer_kind,
- NULL, tmp->value.character.length);
- else
- goto cleanup;
-
- break;
-
- case INQUIRY_KIND:
- if (tmp->ts.type == BT_DERIVED || tmp->ts.type == BT_CLASS)
- goto cleanup;
-
- if (!gfc_notify_std (GFC_STD_F2003, "KIND part_ref at %C"))
- goto cleanup;
-
- *newp = gfc_get_int_expr (gfc_default_integer_kind,
- NULL, tmp->ts.kind);
- break;
-
- case INQUIRY_RE:
- if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT)
- goto cleanup;
-
- if (!gfc_notify_std (GFC_STD_F2008, "RE part_ref at %C"))
- goto cleanup;
-
- *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where);
- mpfr_set ((*newp)->value.real,
- mpc_realref (tmp->value.complex), GFC_RND_MODE);
- break;
-
- case INQUIRY_IM:
- if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT)
- goto cleanup;
-
- if (!gfc_notify_std (GFC_STD_F2008, "IM part_ref at %C"))
- goto cleanup;
-
- *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where);
- mpfr_set ((*newp)->value.real,
- mpc_imagref (tmp->value.complex), GFC_RND_MODE);
- break;
- }
- tmp = gfc_copy_expr (*newp);
- }
-
- if (!(*newp))
- goto cleanup;
- else if ((*newp)->expr_type != EXPR_CONSTANT)
- {
- gfc_free_expr (*newp);
- goto cleanup;
- }
-
- gfc_free_expr (tmp);
- return true;
-
-cleanup:
- gfc_free_expr (tmp);
- return false;
-}
-
-
-
-/* Simplify a subobject reference of a constructor. This occurs when
- parameter variable values are substituted. */
-
-static bool
-simplify_const_ref (gfc_expr *p)
-{
- gfc_constructor *cons, *c;
- gfc_expr *newp = NULL;
- gfc_ref *last_ref;
-
- while (p->ref)
- {
- switch (p->ref->type)
- {
- case REF_ARRAY:
- switch (p->ref->u.ar.type)
- {
- case AR_ELEMENT:
- /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
- will generate this. */
- if (p->expr_type != EXPR_ARRAY)
- {
- remove_subobject_ref (p, NULL);
- break;
- }
- if (!find_array_element (p->value.constructor, &p->ref->u.ar, &cons))
- return false;
-
- if (!cons)
- return true;
-
- remove_subobject_ref (p, cons);
- break;
-
- case AR_SECTION:
- if (!find_array_section (p, p->ref))
- return false;
- p->ref->u.ar.type = AR_FULL;
-
- /* Fall through. */
-
- case AR_FULL:
- if (p->ref->next != NULL
- && (p->ts.type == BT_CHARACTER || gfc_bt_struct (p->ts.type)))
- {
- for (c = gfc_constructor_first (p->value.constructor);
- c; c = gfc_constructor_next (c))
- {
- c->expr->ref = gfc_copy_ref (p->ref->next);
- if (!simplify_const_ref (c->expr))
- return false;
- }
-
- if (gfc_bt_struct (p->ts.type)
- && p->ref->next
- && (c = gfc_constructor_first (p->value.constructor)))
- {
- /* There may have been component references. */
- p->ts = c->expr->ts;
- }
-
- last_ref = p->ref;
- for (; last_ref->next; last_ref = last_ref->next) {};
-
- if (p->ts.type == BT_CHARACTER
- && last_ref->type == REF_SUBSTRING)
- {
- /* If this is a CHARACTER array and we possibly took
- a substring out of it, update the type-spec's
- character length according to the first element
- (as all should have the same length). */
- gfc_charlen_t string_len;
- if ((c = gfc_constructor_first (p->value.constructor)))
- {
- const gfc_expr* first = c->expr;
- gcc_assert (first->expr_type == EXPR_CONSTANT);
- gcc_assert (first->ts.type == BT_CHARACTER);
- string_len = first->value.character.length;
- }
- else
- string_len = 0;
-
- if (!p->ts.u.cl)
- {
- if (p->symtree)
- p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns,
- NULL);
- else
- p->ts.u.cl = gfc_new_charlen (gfc_current_ns,
- NULL);
- }
- else
- gfc_free_expr (p->ts.u.cl->length);
-
- p->ts.u.cl->length
- = gfc_get_int_expr (gfc_charlen_int_kind,
- NULL, string_len);
- }
- }
- gfc_free_ref_list (p->ref);
- p->ref = NULL;
- break;
-
- default:
- return true;
- }
-
- break;
-
- case REF_COMPONENT:
- cons = find_component_ref (p->value.constructor, p->ref);
- remove_subobject_ref (p, cons);
- break;
-
- case REF_INQUIRY:
- if (!find_inquiry_ref (p, &newp))
- return false;
-
- gfc_replace_expr (p, newp);
- gfc_free_ref_list (p->ref);
- p->ref = NULL;
- break;
-
- case REF_SUBSTRING:
- if (!find_substring_ref (p, &newp))
- return false;
-
- gfc_replace_expr (p, newp);
- gfc_free_ref_list (p->ref);
- p->ref = NULL;
- break;
- }
- }
-
- return true;
-}
-
-
-/* Simplify a chain of references. */
-
-static bool
-simplify_ref_chain (gfc_ref *ref, int type, gfc_expr **p)
-{
- int n;
- gfc_expr *newp;
-
- for (; ref; ref = ref->next)
- {
- switch (ref->type)
- {
- case REF_ARRAY:
- for (n = 0; n < ref->u.ar.dimen; n++)
- {
- if (!gfc_simplify_expr (ref->u.ar.start[n], type))
- return false;
- if (!gfc_simplify_expr (ref->u.ar.end[n], type))
- return false;
- if (!gfc_simplify_expr (ref->u.ar.stride[n], type))
- return false;
- }
- break;
-
- case REF_SUBSTRING:
- if (!gfc_simplify_expr (ref->u.ss.start, type))
- return false;
- if (!gfc_simplify_expr (ref->u.ss.end, type))
- return false;
- break;
-
- case REF_INQUIRY:
- if (!find_inquiry_ref (*p, &newp))
- return false;
-
- gfc_replace_expr (*p, newp);
- gfc_free_ref_list ((*p)->ref);
- (*p)->ref = NULL;
- return true;
-
- default:
- break;
- }
- }
- return true;
-}
-
-
-/* Try to substitute the value of a parameter variable. */
-
-static bool
-simplify_parameter_variable (gfc_expr *p, int type)
-{
- gfc_expr *e;
- bool t;
-
- /* Set rank and check array ref; as resolve_variable calls
- gfc_simplify_expr, call gfc_resolve_ref + gfc_expression_rank instead. */
- if (!gfc_resolve_ref (p))
- {
- gfc_error_check ();
- return false;
- }
- gfc_expression_rank (p);
-
- /* Is this an inquiry? */
- bool inquiry = false;
- gfc_ref* ref = p->ref;
- while (ref)
- {
- if (ref->type == REF_INQUIRY)
- break;
- ref = ref->next;
- }
- if (ref && ref->type == REF_INQUIRY)
- inquiry = ref->u.i == INQUIRY_LEN || ref->u.i == INQUIRY_KIND;
-
- if (gfc_is_size_zero_array (p))
- {
- if (p->expr_type == EXPR_ARRAY)
- return true;
-
- e = gfc_get_expr ();
- e->expr_type = EXPR_ARRAY;
- e->ts = p->ts;
- e->rank = p->rank;
- e->value.constructor = NULL;
- e->shape = gfc_copy_shape (p->shape, p->rank);
- e->where = p->where;
- /* If %kind and %len are not used then we're done, otherwise
- drop through for simplification. */
- if (!inquiry)
- {
- gfc_replace_expr (p, e);
- return true;
- }
- }
- else
- {
- e = gfc_copy_expr (p->symtree->n.sym->value);
- if (e == NULL)
- return false;
-
- gfc_free_shape (&e->shape, e->rank);
- e->shape = gfc_copy_shape (p->shape, p->rank);
- e->rank = p->rank;
-
- if (e->ts.type == BT_CHARACTER && p->ts.u.cl)
- e->ts = p->ts;
- }
-
- if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL)
- e->ts.u.cl = gfc_new_charlen (gfc_current_ns, p->ts.u.cl);
-
- /* Do not copy subobject refs for constant. */
- if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
- e->ref = gfc_copy_ref (p->ref);
- t = gfc_simplify_expr (e, type);
- e->where = p->where;
-
- /* Only use the simplification if it eliminated all subobject references. */
- if (t && !e->ref)
- gfc_replace_expr (p, e);
- else
- gfc_free_expr (e);
-
- return t;
-}
-
-
-static bool
-scalarize_intrinsic_call (gfc_expr *, bool init_flag);
-
-/* Given an expression, simplify it by collapsing constant
- expressions. Most simplification takes place when the expression
- tree is being constructed. If an intrinsic function is simplified
- at some point, we get called again to collapse the result against
- other constants.
-
- We work by recursively simplifying expression nodes, simplifying
- intrinsic functions where possible, which can lead to further
- constant collapsing. If an operator has constant operand(s), we
- rip the expression apart, and rebuild it, hoping that it becomes
- something simpler.
-
- The expression type is defined for:
- 0 Basic expression parsing
- 1 Simplifying array constructors -- will substitute
- iterator values.
- Returns false on error, true otherwise.
- NOTE: Will return true even if the expression cannot be simplified. */
-
-bool
-gfc_simplify_expr (gfc_expr *p, int type)
-{
- gfc_actual_arglist *ap;
- gfc_intrinsic_sym* isym = NULL;
-
-
- if (p == NULL)
- return true;
-
- switch (p->expr_type)
- {
- case EXPR_CONSTANT:
- if (p->ref && p->ref->type == REF_INQUIRY)
- simplify_ref_chain (p->ref, type, &p);
- break;
- case EXPR_NULL:
- break;
-
- case EXPR_FUNCTION:
- // For array-bound functions, we don't need to optimize
- // the 'array' argument. In particular, if the argument
- // is a PARAMETER, simplifying might convert an EXPR_VARIABLE
- // into an EXPR_ARRAY; the latter has lbound = 1, the former
- // can have any lbound.
- ap = p->value.function.actual;
- if (p->value.function.isym &&
- (p->value.function.isym->id == GFC_ISYM_LBOUND
- || p->value.function.isym->id == GFC_ISYM_UBOUND
- || p->value.function.isym->id == GFC_ISYM_LCOBOUND
- || p->value.function.isym->id == GFC_ISYM_UCOBOUND
- || p->value.function.isym->id == GFC_ISYM_SHAPE))
- ap = ap->next;
-
- for ( ; ap; ap = ap->next)
- if (!gfc_simplify_expr (ap->expr, type))
- return false;
-
- if (p->value.function.isym != NULL
- && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
- return false;
-
- if (p->symtree && (p->value.function.isym || p->ts.type == BT_UNKNOWN))
- {
- isym = gfc_find_function (p->symtree->n.sym->name);
- if (isym && isym->elemental)
- scalarize_intrinsic_call (p, false);
- }
-
- break;
-
- case EXPR_SUBSTRING:
- if (!simplify_ref_chain (p->ref, type, &p))
- return false;
-
- if (gfc_is_constant_expr (p))
- {
- gfc_char_t *s;
- HOST_WIDE_INT start, end;
-
- start = 0;
- if (p->ref && p->ref->u.ss.start)
- {
- gfc_extract_hwi (p->ref->u.ss.start, &start);
- start--; /* Convert from one-based to zero-based. */
- }
-
- end = p->value.character.length;
- if (p->ref && p->ref->u.ss.end)
- gfc_extract_hwi (p->ref->u.ss.end, &end);
-
- if (end < start)
- end = start;
-
- s = gfc_get_wide_string (end - start + 2);
- memcpy (s, p->value.character.string + start,
- (end - start) * sizeof (gfc_char_t));
- s[end - start + 1] = '\0'; /* TODO: C-style string. */
- free (p->value.character.string);
- p->value.character.string = s;
- p->value.character.length = end - start;
- p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
- p->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
- NULL,
- p->value.character.length);
- gfc_free_ref_list (p->ref);
- p->ref = NULL;
- p->expr_type = EXPR_CONSTANT;
- }
- break;
-
- case EXPR_OP:
- if (!simplify_intrinsic_op (p, type))
- return false;
- break;
-
- case EXPR_VARIABLE:
- /* Only substitute array parameter variables if we are in an
- initialization expression, or we want a subsection. */
- if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
- && (gfc_init_expr_flag || p->ref
- || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
- {
- if (!simplify_parameter_variable (p, type))
- return false;
- break;
- }
-
- if (type == 1)
- {
- gfc_simplify_iterator_var (p);
- }
-
- /* Simplify subcomponent references. */
- if (!simplify_ref_chain (p->ref, type, &p))
- return false;
-
- break;
-
- case EXPR_STRUCTURE:
- case EXPR_ARRAY:
- if (!simplify_ref_chain (p->ref, type, &p))
- return false;
-
- /* If the following conditions hold, we found something like kind type
- inquiry of the form a(2)%kind while simplify the ref chain. */
- if (p->expr_type == EXPR_CONSTANT && !p->ref && !p->rank && !p->shape)
- return true;
-
- if (!simplify_constructor (p->value.constructor, type))
- return false;
-
- if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
- && p->ref->u.ar.type == AR_FULL)
- gfc_expand_constructor (p, false);
-
- if (!simplify_const_ref (p))
- return false;
-
- break;
-
- case EXPR_COMPCALL:
- case EXPR_PPC:
- break;
-
- case EXPR_UNKNOWN:
- gcc_unreachable ();
- }
-
- return true;
-}
-
-
-/* Try simplification of an expression via gfc_simplify_expr.
- When an error occurs (arithmetic or otherwise), roll back. */
-
-bool
-gfc_try_simplify_expr (gfc_expr *e, int type)
-{
- gfc_expr *n;
- bool t, saved_div0;
-
- if (e == NULL || e->expr_type == EXPR_CONSTANT)
- return true;
-
- saved_div0 = gfc_seen_div0;
- gfc_seen_div0 = false;
- n = gfc_copy_expr (e);
- t = gfc_simplify_expr (n, type) && !gfc_seen_div0;
- if (t)
- gfc_replace_expr (e, n);
- else
- gfc_free_expr (n);
- gfc_seen_div0 = saved_div0;
- return t;
-}
-
-
-/* Returns the type of an expression with the exception that iterator
- variables are automatically integers no matter what else they may
- be declared as. */
-
-static bt
-et0 (gfc_expr *e)
-{
- if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e))
- return BT_INTEGER;
-
- return e->ts.type;
-}
-
-
-/* Scalarize an expression for an elemental intrinsic call. */
-
-static bool
-scalarize_intrinsic_call (gfc_expr *e, bool init_flag)
-{
- gfc_actual_arglist *a, *b;
- gfc_constructor_base ctor;
- gfc_constructor *args[5] = {}; /* Avoid uninitialized warnings. */
- gfc_constructor *ci, *new_ctor;
- gfc_expr *expr, *old, *p;
- int n, i, rank[5], array_arg;
-
- if (e == NULL)
- return false;
-
- a = e->value.function.actual;
- for (; a; a = a->next)
- if (a->expr && !gfc_is_constant_expr (a->expr))
- return false;
-
- /* Find which, if any, arguments are arrays. Assume that the old
- expression carries the type information and that the first arg
- that is an array expression carries all the shape information.*/
- n = array_arg = 0;
- a = e->value.function.actual;
- for (; a; a = a->next)
- {
- n++;
- if (!a->expr || a->expr->expr_type != EXPR_ARRAY)
- continue;
- array_arg = n;
- expr = gfc_copy_expr (a->expr);
- break;
- }
-
- if (!array_arg)
- return false;
-
- old = gfc_copy_expr (e);
-
- gfc_constructor_free (expr->value.constructor);
- expr->value.constructor = NULL;
- expr->ts = old->ts;
- expr->where = old->where;
- expr->expr_type = EXPR_ARRAY;
-
- /* Copy the array argument constructors into an array, with nulls
- for the scalars. */
- n = 0;
- a = old->value.function.actual;
- for (; a; a = a->next)
- {
- /* Check that this is OK for an initialization expression. */
- if (a->expr && init_flag && !gfc_check_init_expr (a->expr))
- goto cleanup;
-
- rank[n] = 0;
- if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
- {
- rank[n] = a->expr->rank;
- ctor = a->expr->symtree->n.sym->value->value.constructor;
- args[n] = gfc_constructor_first (ctor);
- }
- else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
- {
- if (a->expr->rank)
- rank[n] = a->expr->rank;
- else
- rank[n] = 1;
- ctor = gfc_constructor_copy (a->expr->value.constructor);
- args[n] = gfc_constructor_first (ctor);
- }
- else
- args[n] = NULL;
-
- n++;
- }
-
- /* Using the array argument as the master, step through the array
- calling the function for each element and advancing the array
- constructors together. */
- for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci))
- {
- new_ctor = gfc_constructor_append_expr (&expr->value.constructor,
- gfc_copy_expr (old), NULL);
-
- gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
- a = NULL;
- b = old->value.function.actual;
- for (i = 0; i < n; i++)
- {
- if (a == NULL)
- new_ctor->expr->value.function.actual
- = a = gfc_get_actual_arglist ();
- else
- {
- a->next = gfc_get_actual_arglist ();
- a = a->next;
- }
-
- if (args[i])
- a->expr = gfc_copy_expr (args[i]->expr);
- else
- a->expr = gfc_copy_expr (b->expr);
-
- b = b->next;
- }
-
- /* Simplify the function calls. If the simplification fails, the
- error will be flagged up down-stream or the library will deal
- with it. */
- p = gfc_copy_expr (new_ctor->expr);
-
- if (!gfc_simplify_expr (p, init_flag))
- gfc_free_expr (p);
- else
- gfc_replace_expr (new_ctor->expr, p);
-
- for (i = 0; i < n; i++)
- if (args[i])
- args[i] = gfc_constructor_next (args[i]);
-
- for (i = 1; i < n; i++)
- if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
- || (args[i] == NULL && args[array_arg - 1] != NULL)))
- goto compliance;
- }
-
- free_expr0 (e);
- *e = *expr;
- /* Free "expr" but not the pointers it contains. */
- free (expr);
- gfc_free_expr (old);
- return true;
-
-compliance:
- gfc_error_now ("elemental function arguments at %C are not compliant");
-
-cleanup:
- gfc_free_expr (expr);
- gfc_free_expr (old);
- return false;
-}
-
-
-static bool
-check_intrinsic_op (gfc_expr *e, bool (*check_function) (gfc_expr *))
-{
- gfc_expr *op1 = e->value.op.op1;
- gfc_expr *op2 = e->value.op.op2;
-
- if (!(*check_function)(op1))
- return false;
-
- switch (e->value.op.op)
- {
- case INTRINSIC_UPLUS:
- case INTRINSIC_UMINUS:
- if (!numeric_type (et0 (op1)))
- goto not_numeric;
- break;
-
- case INTRINSIC_EQ:
- case INTRINSIC_EQ_OS:
- case INTRINSIC_NE:
- case INTRINSIC_NE_OS:
- case INTRINSIC_GT:
- case INTRINSIC_GT_OS:
- case INTRINSIC_GE:
- case INTRINSIC_GE_OS:
- case INTRINSIC_LT:
- case INTRINSIC_LT_OS:
- case INTRINSIC_LE:
- case INTRINSIC_LE_OS:
- if (!(*check_function)(op2))
- return false;
-
- if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
- && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
- {
- gfc_error ("Numeric or CHARACTER operands are required in "
- "expression at %L", &e->where);
- return false;
- }
- break;
-
- case INTRINSIC_PLUS:
- case INTRINSIC_MINUS:
- case INTRINSIC_TIMES:
- case INTRINSIC_DIVIDE:
- case INTRINSIC_POWER:
- if (!(*check_function)(op2))
- return false;
-
- if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
- goto not_numeric;
-
- break;
-
- case INTRINSIC_CONCAT:
- if (!(*check_function)(op2))
- return false;
-
- if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
- {
- gfc_error ("Concatenation operator in expression at %L "
- "must have two CHARACTER operands", &op1->where);
- return false;
- }
-
- if (op1->ts.kind != op2->ts.kind)
- {
- gfc_error ("Concat operator at %L must concatenate strings of the "
- "same kind", &e->where);
- return false;
- }
-
- break;
-
- case INTRINSIC_NOT:
- if (et0 (op1) != BT_LOGICAL)
- {
- gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
- "operand", &op1->where);
- return false;
- }
-
- break;
-
- case INTRINSIC_AND:
- case INTRINSIC_OR:
- case INTRINSIC_EQV:
- case INTRINSIC_NEQV:
- if (!(*check_function)(op2))
- return false;
-
- if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
- {
- gfc_error ("LOGICAL operands are required in expression at %L",
- &e->where);
- return false;
- }
-
- break;
-
- case INTRINSIC_PARENTHESES:
- break;
-
- default:
- gfc_error ("Only intrinsic operators can be used in expression at %L",
- &e->where);
- return false;
- }
-
- return true;
-
-not_numeric:
- gfc_error ("Numeric operands are required in expression at %L", &e->where);
-
- return false;
-}
-
-/* F2003, 7.1.7 (3): In init expression, allocatable components
- must not be data-initialized. */
-static bool
-check_alloc_comp_init (gfc_expr *e)
-{
- gfc_component *comp;
- gfc_constructor *ctor;
-
- gcc_assert (e->expr_type == EXPR_STRUCTURE);
- gcc_assert (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS);
-
- for (comp = e->ts.u.derived->components,
- ctor = gfc_constructor_first (e->value.constructor);
- comp; comp = comp->next, ctor = gfc_constructor_next (ctor))
- {
- if (comp->attr.allocatable && ctor->expr
- && ctor->expr->expr_type != EXPR_NULL)
- {
- gfc_error ("Invalid initialization expression for ALLOCATABLE "
- "component %qs in structure constructor at %L",
- comp->name, &ctor->expr->where);
- return false;
- }
- }
-
- return true;
-}
-
-static match
-check_init_expr_arguments (gfc_expr *e)
-{
- gfc_actual_arglist *ap;
-
- for (ap = e->value.function.actual; ap; ap = ap->next)
- if (!gfc_check_init_expr (ap->expr))
- return MATCH_ERROR;
-
- return MATCH_YES;
-}
-
-static bool check_restricted (gfc_expr *);
-
-/* F95, 7.1.6.1, Initialization expressions, (7)
- F2003, 7.1.7 Initialization expression, (8)
- F2008, 7.1.12 Constant expression, (4) */
-
-static match
-check_inquiry (gfc_expr *e, int not_restricted)
-{
- const char *name;
- const char *const *functions;
-
- static const char *const inquiry_func_f95[] = {
- "lbound", "shape", "size", "ubound",
- "bit_size", "len", "kind",
- "digits", "epsilon", "huge", "maxexponent", "minexponent",
- "precision", "radix", "range", "tiny",
- NULL
- };
-
- static const char *const inquiry_func_f2003[] = {
- "lbound", "shape", "size", "ubound",
- "bit_size", "len", "kind",
- "digits", "epsilon", "huge", "maxexponent", "minexponent",
- "precision", "radix", "range", "tiny",
- "new_line", NULL
- };
-
- /* std=f2008+ or -std=gnu */
- static const char *const inquiry_func_gnu[] = {
- "lbound", "shape", "size", "ubound",
- "bit_size", "len", "kind",
- "digits", "epsilon", "huge", "maxexponent", "minexponent",
- "precision", "radix", "range", "tiny",
- "new_line", "storage_size", NULL
- };
-
- int i = 0;
- gfc_actual_arglist *ap;
- gfc_symbol *sym;
- gfc_symbol *asym;
-
- if (!e->value.function.isym
- || !e->value.function.isym->inquiry)
- return MATCH_NO;
-
- /* An undeclared parameter will get us here (PR25018). */
- if (e->symtree == NULL)
- return MATCH_NO;
-
- sym = e->symtree->n.sym;
-
- if (sym->from_intmod)
- {
- if (sym->from_intmod == INTMOD_ISO_FORTRAN_ENV
- && sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS
- && sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION)
- return MATCH_NO;
-
- if (sym->from_intmod == INTMOD_ISO_C_BINDING
- && sym->intmod_sym_id != ISOCBINDING_C_SIZEOF)
- return MATCH_NO;
- }
- else
- {
- name = sym->name;
-
- functions = inquiry_func_gnu;
- if (gfc_option.warn_std & GFC_STD_F2003)
- functions = inquiry_func_f2003;
- if (gfc_option.warn_std & GFC_STD_F95)
- functions = inquiry_func_f95;
-
- for (i = 0; functions[i]; i++)
- if (strcmp (functions[i], name) == 0)
- break;
-
- if (functions[i] == NULL)
- return MATCH_ERROR;
- }
-
- /* At this point we have an inquiry function with a variable argument. The
- type of the variable might be undefined, but we need it now, because the
- arguments of these functions are not allowed to be undefined. */
-
- for (ap = e->value.function.actual; ap; ap = ap->next)
- {
- if (!ap->expr)
- continue;
-
- asym = ap->expr->symtree ? ap->expr->symtree->n.sym : NULL;
-
- if (ap->expr->ts.type == BT_UNKNOWN)
- {
- if (asym && asym->ts.type == BT_UNKNOWN
- && !gfc_set_default_type (asym, 0, gfc_current_ns))
- return MATCH_NO;
-
- ap->expr->ts = asym->ts;
- }
-
- if (asym && asym->assoc && asym->assoc->target
- && asym->assoc->target->expr_type == EXPR_CONSTANT)
- {
- gfc_free_expr (ap->expr);
- ap->expr = gfc_copy_expr (asym->assoc->target);
- }
-
- /* Assumed character length will not reduce to a constant expression
- with LEN, as required by the standard. */
- if (i == 5 && not_restricted && asym
- && asym->ts.type == BT_CHARACTER
- && ((asym->ts.u.cl && asym->ts.u.cl->length == NULL)
- || asym->ts.deferred))
- {
- gfc_error ("Assumed or deferred character length variable %qs "
- "in constant expression at %L",
- asym->name, &ap->expr->where);
- return MATCH_ERROR;
- }
- else if (not_restricted && !gfc_check_init_expr (ap->expr))
- return MATCH_ERROR;
-
- if (not_restricted == 0
- && ap->expr->expr_type != EXPR_VARIABLE
- && !check_restricted (ap->expr))
- return MATCH_ERROR;
-
- if (not_restricted == 0
- && ap->expr->expr_type == EXPR_VARIABLE
- && asym->attr.dummy && asym->attr.optional)
- return MATCH_NO;
- }
-
- return MATCH_YES;
-}
-
-
-/* F95, 7.1.6.1, Initialization expressions, (5)
- F2003, 7.1.7 Initialization expression, (5) */
-
-static match
-check_transformational (gfc_expr *e)
-{
- static const char * const trans_func_f95[] = {
- "repeat", "reshape", "selected_int_kind",
- "selected_real_kind", "transfer", "trim", NULL
- };
-
- static const char * const trans_func_f2003[] = {
- "all", "any", "count", "dot_product", "matmul", "null", "pack",
- "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
- "selected_real_kind", "spread", "sum", "transfer", "transpose",
- "trim", "unpack", NULL
- };
-
- static const char * const trans_func_f2008[] = {
- "all", "any", "count", "dot_product", "matmul", "null", "pack",
- "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
- "selected_real_kind", "spread", "sum", "transfer", "transpose",
- "trim", "unpack", "findloc", NULL
- };
-
- int i;
- const char *name;
- const char *const *functions;
-
- if (!e->value.function.isym
- || !e->value.function.isym->transformational)
- return MATCH_NO;
-
- name = e->symtree->n.sym->name;
-
- if (gfc_option.allow_std & GFC_STD_F2008)
- functions = trans_func_f2008;
- else if (gfc_option.allow_std & GFC_STD_F2003)
- functions = trans_func_f2003;
- else
- functions = trans_func_f95;
-
- /* NULL() is dealt with below. */
- if (strcmp ("null", name) == 0)
- return MATCH_NO;
-
- for (i = 0; functions[i]; i++)
- if (strcmp (functions[i], name) == 0)
- break;
-
- if (functions[i] == NULL)
- {
- gfc_error ("transformational intrinsic %qs at %L is not permitted "
- "in an initialization expression", name, &e->where);
- return MATCH_ERROR;
- }
-
- return check_init_expr_arguments (e);
-}
-
-
-/* F95, 7.1.6.1, Initialization expressions, (6)
- F2003, 7.1.7 Initialization expression, (6) */
-
-static match
-check_null (gfc_expr *e)
-{
- if (strcmp ("null", e->symtree->n.sym->name) != 0)
- return MATCH_NO;
-
- return check_init_expr_arguments (e);
-}
-
-
-static match
-check_elemental (gfc_expr *e)
-{
- if (!e->value.function.isym
- || !e->value.function.isym->elemental)
- return MATCH_NO;
-
- if (e->ts.type != BT_INTEGER
- && e->ts.type != BT_CHARACTER
- && !gfc_notify_std (GFC_STD_F2003, "Evaluation of nonstandard "
- "initialization expression at %L", &e->where))
- return MATCH_ERROR;
-
- return check_init_expr_arguments (e);
-}
-
-
-static match
-check_conversion (gfc_expr *e)
-{
- if (!e->value.function.isym
- || !e->value.function.isym->conversion)
- return MATCH_NO;
-
- return check_init_expr_arguments (e);
-}
-
-
-/* Verify that an expression is an initialization expression. A side
- effect is that the expression tree is reduced to a single constant
- node if all goes well. This would normally happen when the
- expression is constructed but function references are assumed to be
- intrinsics in the context of initialization expressions. If
- false is returned an error message has been generated. */
-
-bool
-gfc_check_init_expr (gfc_expr *e)
-{
- match m;
- bool t;
-
- if (e == NULL)
- return true;
-
- switch (e->expr_type)
- {
- case EXPR_OP:
- t = check_intrinsic_op (e, gfc_check_init_expr);
- if (t)
- t = gfc_simplify_expr (e, 0);
-
- break;
-
- case EXPR_FUNCTION:
- t = false;
-
- {
- bool conversion;
- gfc_intrinsic_sym* isym = NULL;
- gfc_symbol* sym = e->symtree->n.sym;
-
- /* Simplify here the intrinsics from the IEEE_ARITHMETIC and
- IEEE_EXCEPTIONS modules. */
- int mod = sym->from_intmod;
- if (mod == INTMOD_NONE && sym->generic)
- mod = sym->generic->sym->from_intmod;
- if (mod == INTMOD_IEEE_ARITHMETIC || mod == INTMOD_IEEE_EXCEPTIONS)
- {
- gfc_expr *new_expr = gfc_simplify_ieee_functions (e);
- if (new_expr)
- {
- gfc_replace_expr (e, new_expr);
- t = true;
- break;
- }
- }
-
- /* If a conversion function, e.g., __convert_i8_i4, was inserted
- into an array constructor, we need to skip the error check here.
- Conversion errors are caught below in scalarize_intrinsic_call. */
- conversion = e->value.function.isym
- && (e->value.function.isym->conversion == 1);
-
- if (!conversion && (!gfc_is_intrinsic (sym, 0, e->where)
- || (m = gfc_intrinsic_func_interface (e, 0)) == MATCH_NO))
- {
- gfc_error ("Function %qs in initialization expression at %L "
- "must be an intrinsic function",
- e->symtree->n.sym->name, &e->where);
- break;
- }
-
- if ((m = check_conversion (e)) == MATCH_NO
- && (m = check_inquiry (e, 1)) == MATCH_NO
- && (m = check_null (e)) == MATCH_NO
- && (m = check_transformational (e)) == MATCH_NO
- && (m = check_elemental (e)) == MATCH_NO)
- {
- gfc_error ("Intrinsic function %qs at %L is not permitted "
- "in an initialization expression",
- e->symtree->n.sym->name, &e->where);
- m = MATCH_ERROR;
- }
-
- if (m == MATCH_ERROR)
- return false;
-
- /* Try to scalarize an elemental intrinsic function that has an
- array argument. */
- isym = gfc_find_function (e->symtree->n.sym->name);
- if (isym && isym->elemental
- && (t = scalarize_intrinsic_call (e, true)))
- break;
- }
-
- if (m == MATCH_YES)
- t = gfc_simplify_expr (e, 0);
-
- break;
-
- case EXPR_VARIABLE:
- t = true;
-
- /* This occurs when parsing pdt templates. */
- if (gfc_expr_attr (e).pdt_kind)
- break;
-
- if (gfc_check_iter_variable (e))
- break;
-
- if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
- {
- /* A PARAMETER shall not be used to define itself, i.e.
- REAL, PARAMETER :: x = transfer(0, x)
- is invalid. */
- if (!e->symtree->n.sym->value)
- {
- gfc_error ("PARAMETER %qs is used at %L before its definition "
- "is complete", e->symtree->n.sym->name, &e->where);
- t = false;
- }
- else
- t = simplify_parameter_variable (e, 0);
-
- break;
- }
-
- if (gfc_in_match_data ())
- break;
-
- t = false;
-
- if (e->symtree->n.sym->as)
- {
- switch (e->symtree->n.sym->as->type)
- {
- case AS_ASSUMED_SIZE:
- gfc_error ("Assumed size array %qs at %L is not permitted "
- "in an initialization expression",
- e->symtree->n.sym->name, &e->where);
- break;
-
- case AS_ASSUMED_SHAPE:
- gfc_error ("Assumed shape array %qs at %L is not permitted "
- "in an initialization expression",
- e->symtree->n.sym->name, &e->where);
- break;
-
- case AS_DEFERRED:
- if (!e->symtree->n.sym->attr.allocatable
- && !e->symtree->n.sym->attr.pointer
- && e->symtree->n.sym->attr.dummy)
- gfc_error ("Assumed-shape array %qs at %L is not permitted "
- "in an initialization expression",
- e->symtree->n.sym->name, &e->where);
- else
- gfc_error ("Deferred array %qs at %L is not permitted "
- "in an initialization expression",
- e->symtree->n.sym->name, &e->where);
- break;
-
- case AS_EXPLICIT:
- gfc_error ("Array %qs at %L is a variable, which does "
- "not reduce to a constant expression",
- e->symtree->n.sym->name, &e->where);
- break;
-
- case AS_ASSUMED_RANK:
- gfc_error ("Assumed-rank array %qs at %L is not permitted "
- "in an initialization expression",
- e->symtree->n.sym->name, &e->where);
- break;
-
- default:
- gcc_unreachable();
- }
- }
- else
- gfc_error ("Parameter %qs at %L has not been declared or is "
- "a variable, which does not reduce to a constant "
- "expression", e->symtree->name, &e->where);
-
- break;
-
- case EXPR_CONSTANT:
- case EXPR_NULL:
- t = true;
- break;
-
- case EXPR_SUBSTRING:
- if (e->ref)
- {
- t = gfc_check_init_expr (e->ref->u.ss.start);
- if (!t)
- break;
-
- t = gfc_check_init_expr (e->ref->u.ss.end);
- if (t)
- t = gfc_simplify_expr (e, 0);
- }
- else
- t = false;
- break;
-
- case EXPR_STRUCTURE:
- t = e->ts.is_iso_c ? true : false;
- if (t)
- break;
-
- t = check_alloc_comp_init (e);
- if (!t)
- break;
-
- t = gfc_check_constructor (e, gfc_check_init_expr);
- if (!t)
- break;
-
- break;
-
- case EXPR_ARRAY:
- t = gfc_check_constructor (e, gfc_check_init_expr);
- if (!t)
- break;
-
- t = gfc_expand_constructor (e, true);
- if (!t)
- break;
-
- t = gfc_check_constructor_type (e);
- break;
-
- default:
- gfc_internal_error ("check_init_expr(): Unknown expression type");
- }
-
- return t;
-}
-
-/* Reduces a general expression to an initialization expression (a constant).
- This used to be part of gfc_match_init_expr.
- Note that this function doesn't free the given expression on false. */
-
-bool
-gfc_reduce_init_expr (gfc_expr *expr)
-{
- bool t;
-
- gfc_init_expr_flag = true;
- t = gfc_resolve_expr (expr);
- if (t)
- t = gfc_check_init_expr (expr);
- gfc_init_expr_flag = false;
-
- if (!t || !expr)
- return false;
-
- if (expr->expr_type == EXPR_ARRAY)
- {
- if (!gfc_check_constructor_type (expr))
- return false;
- if (!gfc_expand_constructor (expr, true))
- return false;
- }
-
- return true;
-}
-
-
-/* Match an initialization expression. We work by first matching an
- expression, then reducing it to a constant. */
-
-match
-gfc_match_init_expr (gfc_expr **result)
-{
- gfc_expr *expr;
- match m;
- bool t;
-
- expr = NULL;
-
- gfc_init_expr_flag = true;
-
- m = gfc_match_expr (&expr);
- if (m != MATCH_YES)
- {
- gfc_init_expr_flag = false;
- return m;
- }
-
- if (gfc_derived_parameter_expr (expr))
- {
- *result = expr;
- gfc_init_expr_flag = false;
- return m;
- }
-
- t = gfc_reduce_init_expr (expr);
- if (!t)
- {
- gfc_free_expr (expr);
- gfc_init_expr_flag = false;
- return MATCH_ERROR;
- }
-
- *result = expr;
- gfc_init_expr_flag = false;
-
- return MATCH_YES;
-}
-
-
-/* Given an actual argument list, test to see that each argument is a
- restricted expression and optionally if the expression type is
- integer or character. */
-
-static bool
-restricted_args (gfc_actual_arglist *a)
-{
- for (; a; a = a->next)
- {
- if (!check_restricted (a->expr))
- return false;
- }
-
- return true;
-}
-
-
-/************* Restricted/specification expressions *************/
-
-
-/* Make sure a non-intrinsic function is a specification function,
- * see F08:7.1.11.5. */
-
-static bool
-external_spec_function (gfc_expr *e)
-{
- gfc_symbol *f;
-
- f = e->value.function.esym;
-
- /* IEEE functions allowed are "a reference to a transformational function
- from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
- "inquiry function from the intrinsic modules IEEE_ARITHMETIC and
- IEEE_EXCEPTIONS". */
- if (f->from_intmod == INTMOD_IEEE_ARITHMETIC
- || f->from_intmod == INTMOD_IEEE_EXCEPTIONS)
- {
- if (!strcmp (f->name, "ieee_selected_real_kind")
- || !strcmp (f->name, "ieee_support_rounding")
- || !strcmp (f->name, "ieee_support_flag")
- || !strcmp (f->name, "ieee_support_halting")
- || !strcmp (f->name, "ieee_support_datatype")
- || !strcmp (f->name, "ieee_support_denormal")
- || !strcmp (f->name, "ieee_support_subnormal")
- || !strcmp (f->name, "ieee_support_divide")
- || !strcmp (f->name, "ieee_support_inf")
- || !strcmp (f->name, "ieee_support_io")
- || !strcmp (f->name, "ieee_support_nan")
- || !strcmp (f->name, "ieee_support_sqrt")
- || !strcmp (f->name, "ieee_support_standard")
- || !strcmp (f->name, "ieee_support_underflow_control"))
- goto function_allowed;
- }
-
- if (f->attr.proc == PROC_ST_FUNCTION)
- {
- gfc_error ("Specification function %qs at %L cannot be a statement "
- "function", f->name, &e->where);
- return false;
- }
-
- if (f->attr.proc == PROC_INTERNAL)
- {
- gfc_error ("Specification function %qs at %L cannot be an internal "
- "function", f->name, &e->where);
- return false;
- }
-
- if (!f->attr.pure && !f->attr.elemental)
- {
- gfc_error ("Specification function %qs at %L must be PURE", f->name,
- &e->where);
- return false;
- }
-
- /* F08:7.1.11.6. */
- if (f->attr.recursive
- && !gfc_notify_std (GFC_STD_F2003,
- "Specification function %qs "
- "at %L cannot be RECURSIVE", f->name, &e->where))
- return false;
-
-function_allowed:
- return restricted_args (e->value.function.actual);
-}
-
-
-/* Check to see that a function reference to an intrinsic is a
- restricted expression. */
-
-static bool
-restricted_intrinsic (gfc_expr *e)
-{
- /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
- if (check_inquiry (e, 0) == MATCH_YES)
- return true;
-
- return restricted_args (e->value.function.actual);
-}
-
-
-/* Check the expressions of an actual arglist. Used by check_restricted. */
-
-static bool
-check_arglist (gfc_actual_arglist* arg, bool (*checker) (gfc_expr*))
-{
- for (; arg; arg = arg->next)
- if (!checker (arg->expr))
- return false;
-
- return true;
-}
-
-
-/* Check the subscription expressions of a reference chain with a checking
- function; used by check_restricted. */
-
-static bool
-check_references (gfc_ref* ref, bool (*checker) (gfc_expr*))
-{
- int dim;
-
- if (!ref)
- return true;
-
- switch (ref->type)
- {
- case REF_ARRAY:
- for (dim = 0; dim < ref->u.ar.dimen; ++dim)
- {
- if (!checker (ref->u.ar.start[dim]))
- return false;
- if (!checker (ref->u.ar.end[dim]))
- return false;
- if (!checker (ref->u.ar.stride[dim]))
- return false;
- }
- break;
-
- case REF_COMPONENT:
- /* Nothing needed, just proceed to next reference. */
- break;
-
- case REF_SUBSTRING:
- if (!checker (ref->u.ss.start))
- return false;
- if (!checker (ref->u.ss.end))
- return false;
- break;
-
- default:
- gcc_unreachable ();
- break;
- }
-
- return check_references (ref->next, checker);
-}
-
-/* Return true if ns is a parent of the current ns. */
-
-static bool
-is_parent_of_current_ns (gfc_namespace *ns)
-{
- gfc_namespace *p;
- for (p = gfc_current_ns->parent; p; p = p->parent)
- if (ns == p)
- return true;
-
- return false;
-}
-
-/* Verify that an expression is a restricted expression. Like its
- cousin check_init_expr(), an error message is generated if we
- return false. */
-
-static bool
-check_restricted (gfc_expr *e)
-{
- gfc_symbol* sym;
- bool t;
-
- if (e == NULL)
- return true;
-
- switch (e->expr_type)
- {
- case EXPR_OP:
- t = check_intrinsic_op (e, check_restricted);
- if (t)
- t = gfc_simplify_expr (e, 0);
-
- break;
-
- case EXPR_FUNCTION:
- if (e->value.function.esym)
- {
- t = check_arglist (e->value.function.actual, &check_restricted);
- if (t)
- t = external_spec_function (e);
- }
- else
- {
- if (e->value.function.isym && e->value.function.isym->inquiry)
- t = true;
- else
- t = check_arglist (e->value.function.actual, &check_restricted);
-
- if (t)
- t = restricted_intrinsic (e);
- }
- break;
-
- case EXPR_VARIABLE:
- sym = e->symtree->n.sym;
- t = false;
-
- /* If a dummy argument appears in a context that is valid for a
- restricted expression in an elemental procedure, it will have
- already been simplified away once we get here. Therefore we
- don't need to jump through hoops to distinguish valid from
- invalid cases. Allowed in F2008 and F2018. */
- if (gfc_notification_std (GFC_STD_F2008)
- && sym->attr.dummy && sym->ns == gfc_current_ns
- && sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
- {
- gfc_error_now ("Dummy argument %qs not "
- "allowed in expression at %L",
- sym->name, &e->where);
- break;
- }
-
- if (sym->attr.optional)
- {
- gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL",
- sym->name, &e->where);
- break;
- }
-
- if (sym->attr.intent == INTENT_OUT)
- {
- gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)",
- sym->name, &e->where);
- break;
- }
-
- /* Check reference chain if any. */
- if (!check_references (e->ref, &check_restricted))
- break;
-
- /* gfc_is_formal_arg broadcasts that a formal argument list is being
- processed in resolve.c(resolve_formal_arglist). This is done so
- that host associated dummy array indices are accepted (PR23446).
- This mechanism also does the same for the specification expressions
- of array-valued functions. */
- if (e->error
- || sym->attr.in_common
- || sym->attr.use_assoc
- || sym->attr.dummy
- || sym->attr.implied_index
- || sym->attr.flavor == FL_PARAMETER
- || is_parent_of_current_ns (sym->ns)
- || (sym->ns->proc_name != NULL
- && sym->ns->proc_name->attr.flavor == FL_MODULE)
- || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
- {
- t = true;
- break;
- }
-
- gfc_error ("Variable %qs cannot appear in the expression at %L",
- sym->name, &e->where);
- /* Prevent a repetition of the error. */
- e->error = 1;
- break;
-
- case EXPR_NULL:
- case EXPR_CONSTANT:
- t = true;
- break;
-
- case EXPR_SUBSTRING:
- t = gfc_specification_expr (e->ref->u.ss.start);
- if (!t)
- break;
-
- t = gfc_specification_expr (e->ref->u.ss.end);
- if (t)
- t = gfc_simplify_expr (e, 0);
-
- break;
-
- case EXPR_STRUCTURE:
- t = gfc_check_constructor (e, check_restricted);
- break;
-
- case EXPR_ARRAY:
- t = gfc_check_constructor (e, check_restricted);
- break;
-
- default:
- gfc_internal_error ("check_restricted(): Unknown expression type");
- }
-
- return t;
-}
-
-
-/* Check to see that an expression is a specification expression. If
- we return false, an error has been generated. */
-
-bool
-gfc_specification_expr (gfc_expr *e)
-{
- gfc_component *comp;
-
- if (e == NULL)
- return true;
-
- if (e->ts.type != BT_INTEGER)
- {
- gfc_error ("Expression at %L must be of INTEGER type, found %s",
- &e->where, gfc_basic_typename (e->ts.type));
- return false;
- }
-
- comp = gfc_get_proc_ptr_comp (e);
- if (e->expr_type == EXPR_FUNCTION
- && !e->value.function.isym
- && !e->value.function.esym
- && !gfc_pure (e->symtree->n.sym)
- && (!comp || !comp->attr.pure))
- {
- gfc_error ("Function %qs at %L must be PURE",
- e->symtree->n.sym->name, &e->where);
- /* Prevent repeat error messages. */
- e->symtree->n.sym->attr.pure = 1;
- return false;
- }
-
- if (e->rank != 0)
- {
- gfc_error ("Expression at %L must be scalar", &e->where);
- return false;
- }
-
- if (!gfc_simplify_expr (e, 0))
- return false;
-
- return check_restricted (e);
-}
-
-
-/************** Expression conformance checks. *************/
-
-/* Given two expressions, make sure that the arrays are conformable. */
-
-bool
-gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...)
-{
- int op1_flag, op2_flag, d;
- mpz_t op1_size, op2_size;
- bool t;
-
- va_list argp;
- char buffer[240];
-
- if (op1->rank == 0 || op2->rank == 0)
- return true;
-
- va_start (argp, optype_msgid);
- d = vsnprintf (buffer, sizeof (buffer), optype_msgid, argp);
- va_end (argp);
- if (d < 1 || d >= (int) sizeof (buffer)) /* Reject truncation. */
- gfc_internal_error ("optype_msgid overflow: %d", d);
-
- if (op1->rank != op2->rank)
- {
- gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer),
- op1->rank, op2->rank, &op1->where);
- return false;
- }
-
- t = true;
-
- for (d = 0; d < op1->rank; d++)
- {
- op1_flag = gfc_array_dimen_size(op1, d, &op1_size);
- op2_flag = gfc_array_dimen_size(op2, d, &op2_size);
-
- if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
- {
- gfc_error ("Different shape for %s at %L on dimension %d "
- "(%d and %d)", _(buffer), &op1->where, d + 1,
- (int) mpz_get_si (op1_size),
- (int) mpz_get_si (op2_size));
-
- t = false;
- }
-
- if (op1_flag)
- mpz_clear (op1_size);
- if (op2_flag)
- mpz_clear (op2_size);
-
- if (!t)
- return false;
- }
-
- return true;
-}
-
-
-/* Given an assignable expression and an arbitrary expression, make
- sure that the assignment can take place. Only add a call to the intrinsic
- conversion routines, when allow_convert is set. When this assign is a
- coarray call, then the convert is done by the coarray routine implictly and
- adding the intrinsic conversion would do harm in most cases. */
-
-bool
-gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform,
- bool allow_convert)
-{
- gfc_symbol *sym;
- gfc_ref *ref;
- int has_pointer;
-
- sym = lvalue->symtree->n.sym;
-
- /* See if this is the component or subcomponent of a pointer and guard
- against assignment to LEN or KIND part-refs. */
- has_pointer = sym->attr.pointer;
- for (ref = lvalue->ref; ref; ref = ref->next)
- {
- if (!has_pointer && ref->type == REF_COMPONENT
- && ref->u.c.component->attr.pointer)
- has_pointer = 1;
- else if (ref->type == REF_INQUIRY
- && (ref->u.i == INQUIRY_LEN || ref->u.i == INQUIRY_KIND))
- {
- gfc_error ("Assignment to a LEN or KIND part_ref at %L is not "
- "allowed", &lvalue->where);
- return false;
- }
- }
-
- /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
- variable local to a function subprogram. Its existence begins when
- execution of the function is initiated and ends when execution of the
- function is terminated...
- Therefore, the left hand side is no longer a variable, when it is: */
- if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
- && !sym->attr.external)
- {
- bool bad_proc;
- bad_proc = false;
-
- /* (i) Use associated; */
- if (sym->attr.use_assoc)
- bad_proc = true;
-
- /* (ii) The assignment is in the main program; or */
- if (gfc_current_ns->proc_name
- && gfc_current_ns->proc_name->attr.is_main_program)
- bad_proc = true;
-
- /* (iii) A module or internal procedure... */
- if (gfc_current_ns->proc_name
- && (gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
- || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
- && gfc_current_ns->parent
- && (!(gfc_current_ns->parent->proc_name->attr.function
- || gfc_current_ns->parent->proc_name->attr.subroutine)
- || gfc_current_ns->parent->proc_name->attr.is_main_program))
- {
- /* ... that is not a function... */
- if (gfc_current_ns->proc_name
- && !gfc_current_ns->proc_name->attr.function)
- bad_proc = true;
-
- /* ... or is not an entry and has a different name. */
- if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
- bad_proc = true;
- }
-
- /* (iv) Host associated and not the function symbol or the
- parent result. This picks up sibling references, which
- cannot be entries. */
- if (!sym->attr.entry
- && sym->ns == gfc_current_ns->parent
- && sym != gfc_current_ns->proc_name
- && sym != gfc_current_ns->parent->proc_name->result)
- bad_proc = true;
-
- if (bad_proc)
- {
- gfc_error ("%qs at %L is not a VALUE", sym->name, &lvalue->where);
- return false;
- }
- }
- else
- {
- /* Reject assigning to an external symbol. For initializers, this
- was already done before, in resolve_fl_procedure. */
- if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
- && sym->attr.proc != PROC_MODULE && !rvalue->error)
- {
- gfc_error ("Illegal assignment to external procedure at %L",
- &lvalue->where);
- return false;
- }
- }
-
- if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
- {
- gfc_error ("Incompatible ranks %d and %d in assignment at %L",
- lvalue->rank, rvalue->rank, &lvalue->where);
- return false;
- }
-
- if (lvalue->ts.type == BT_UNKNOWN)
- {
- gfc_error ("Variable type is UNKNOWN in assignment at %L",
- &lvalue->where);
- return false;
- }
-
- if (rvalue->expr_type == EXPR_NULL)
- {
- if (has_pointer && (ref == NULL || ref->next == NULL)
- && lvalue->symtree->n.sym->attr.data)
- return true;
- else
- {
- gfc_error ("NULL appears on right-hand side in assignment at %L",
- &rvalue->where);
- return false;
- }
- }
-
- /* This is possibly a typo: x = f() instead of x => f(). */
- if (warn_surprising
- && rvalue->expr_type == EXPR_FUNCTION && gfc_expr_attr (rvalue).pointer)
- gfc_warning (OPT_Wsurprising,
- "POINTER-valued function appears on right-hand side of "
- "assignment at %L", &rvalue->where);
-
- /* Check size of array assignments. */
- if (lvalue->rank != 0 && rvalue->rank != 0
- && !gfc_check_conformance (lvalue, rvalue, _("array assignment")))
- return false;
-
- /* Handle the case of a BOZ literal on the RHS. */
- if (rvalue->ts.type == BT_BOZ)
- {
- if (lvalue->symtree->n.sym->attr.data)
- {
- if (lvalue->ts.type == BT_INTEGER
- && gfc_boz2int (rvalue, lvalue->ts.kind))
- return true;
-
- if (lvalue->ts.type == BT_REAL
- && gfc_boz2real (rvalue, lvalue->ts.kind))
- {
- if (gfc_invalid_boz ("BOZ literal constant near %L cannot "
- "be assigned to a REAL variable",
- &rvalue->where))
- return false;
- return true;
- }
- }
-
- if (!lvalue->symtree->n.sym->attr.data
- && gfc_invalid_boz ("BOZ literal constant at %L is neither a "
- "data-stmt-constant nor an actual argument to "
- "INT, REAL, DBLE, or CMPLX intrinsic function",
- &rvalue->where))
- return false;
-
- if (lvalue->ts.type == BT_INTEGER
- && gfc_boz2int (rvalue, lvalue->ts.kind))
- return true;
-
- if (lvalue->ts.type == BT_REAL
- && gfc_boz2real (rvalue, lvalue->ts.kind))
- return true;
-
- gfc_error ("BOZ literal constant near %L cannot be assigned to a "
- "%qs variable", &rvalue->where, gfc_typename (lvalue));
- return false;
- }
-
- if (gfc_expr_attr (lvalue).pdt_kind || gfc_expr_attr (lvalue).pdt_len)
- {
- gfc_error ("The assignment to a KIND or LEN component of a "
- "parameterized type at %L is not allowed",
- &lvalue->where);
- return false;
- }
-
- if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
- return true;
-
- /* Only DATA Statements come here. */
- if (!conform)
- {
- locus *where;
-
- /* Numeric can be converted to any other numeric. And Hollerith can be
- converted to any other type. */
- if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
- || rvalue->ts.type == BT_HOLLERITH)
- return true;
-
- if (flag_dec_char_conversions && (gfc_numeric_ts (&lvalue->ts)
- || lvalue->ts.type == BT_LOGICAL)
- && rvalue->ts.type == BT_CHARACTER
- && rvalue->ts.kind == gfc_default_character_kind)
- return true;
-
- if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
- return true;
-
- where = lvalue->where.lb ? &lvalue->where : &rvalue->where;
- gfc_error ("Incompatible types in DATA statement at %L; attempted "
- "conversion of %s to %s", where,
- gfc_typename (rvalue), gfc_typename (lvalue));
-
- return false;
- }
-
- /* Assignment is the only case where character variables of different
- kind values can be converted into one another. */
- if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
- {
- if (lvalue->ts.kind != rvalue->ts.kind && allow_convert)
- return gfc_convert_chartype (rvalue, &lvalue->ts);
- else
- return true;
- }
-
- if (!allow_convert)
- return true;
-
- return gfc_convert_type (rvalue, &lvalue->ts, 1);
-}
-
-
-/* Check that a pointer assignment is OK. We first check lvalue, and
- we only check rvalue if it's not an assignment to NULL() or a
- NULLIFY statement. */
-
-bool
-gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue,
- bool suppress_type_test, bool is_init_expr)
-{
- symbol_attribute attr, lhs_attr;
- gfc_ref *ref;
- bool is_pure, is_implicit_pure, rank_remap;
- int proc_pointer;
- bool same_rank;
-
- if (!lvalue->symtree)
- return false;
-
- lhs_attr = gfc_expr_attr (lvalue);
- if (lvalue->ts.type == BT_UNKNOWN && !lhs_attr.proc_pointer)
- {
- gfc_error ("Pointer assignment target is not a POINTER at %L",
- &lvalue->where);
- return false;
- }
-
- if (lhs_attr.flavor == FL_PROCEDURE && lhs_attr.use_assoc
- && !lhs_attr.proc_pointer)
- {
- gfc_error ("%qs in the pointer assignment at %L cannot be an "
- "l-value since it is a procedure",
- lvalue->symtree->n.sym->name, &lvalue->where);
- return false;
- }
-
- proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
-
- rank_remap = false;
- same_rank = lvalue->rank == rvalue->rank;
- for (ref = lvalue->ref; ref; ref = ref->next)
- {
- if (ref->type == REF_COMPONENT)
- proc_pointer = ref->u.c.component->attr.proc_pointer;
-
- if (ref->type == REF_ARRAY && ref->next == NULL)
- {
- int dim;
-
- if (ref->u.ar.type == AR_FULL)
- break;
-
- if (ref->u.ar.type != AR_SECTION)
- {
- gfc_error ("Expected bounds specification for %qs at %L",
- lvalue->symtree->n.sym->name, &lvalue->where);
- return false;
- }
-
- if (!gfc_notify_std (GFC_STD_F2003, "Bounds specification "
- "for %qs in pointer assignment at %L",
- lvalue->symtree->n.sym->name, &lvalue->where))
- return false;
-
- /* Fortran standard (e.g. F2018, 10.2.2 Pointer assignment):
- *
- * (C1017) If bounds-spec-list is specified, the number of
- * bounds-specs shall equal the rank of data-pointer-object.
- *
- * If bounds-spec-list appears, it specifies the lower bounds.
- *
- * (C1018) If bounds-remapping-list is specified, the number of
- * bounds-remappings shall equal the rank of data-pointer-object.
- *
- * If bounds-remapping-list appears, it specifies the upper and
- * lower bounds of each dimension of the pointer; the pointer target
- * shall be simply contiguous or of rank one.
- *
- * (C1019) If bounds-remapping-list is not specified, the ranks of
- * data-pointer-object and data-target shall be the same.
- *
- * Thus when bounds are given, all lbounds are necessary and either
- * all or none of the upper bounds; no strides are allowed. If the
- * upper bounds are present, we may do rank remapping. */
- for (dim = 0; dim < ref->u.ar.dimen; ++dim)
- {
- if (ref->u.ar.stride[dim])
- {
- gfc_error ("Stride must not be present at %L",
- &lvalue->where);
- return false;
- }
- if (!same_rank && (!ref->u.ar.start[dim] ||!ref->u.ar.end[dim]))
- {
- gfc_error ("Rank remapping requires a "
- "list of %<lower-bound : upper-bound%> "
- "specifications at %L", &lvalue->where);
- return false;
- }
- if (!ref->u.ar.start[dim]
- || ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
- {
- gfc_error ("Expected list of %<lower-bound :%> or "
- "list of %<lower-bound : upper-bound%> "
- "specifications at %L", &lvalue->where);
- return false;
- }
-
- if (dim == 0)
- rank_remap = (ref->u.ar.end[dim] != NULL);
- else
- {
- if ((rank_remap && !ref->u.ar.end[dim]))
- {
- gfc_error ("Rank remapping requires a "
- "list of %<lower-bound : upper-bound%> "
- "specifications at %L", &lvalue->where);
- return false;
- }
- if (!rank_remap && ref->u.ar.end[dim])
- {
- gfc_error ("Expected list of %<lower-bound :%> or "
- "list of %<lower-bound : upper-bound%> "
- "specifications at %L", &lvalue->where);
- return false;
- }
- }
- }
- }
- }
-
- is_pure = gfc_pure (NULL);
- is_implicit_pure = gfc_implicit_pure (NULL);
-
- /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
- kind, etc for lvalue and rvalue must match, and rvalue must be a
- pure variable if we're in a pure function. */
- if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
- return true;
-
- /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
- if (lvalue->expr_type == EXPR_VARIABLE
- && gfc_is_coindexed (lvalue))
- {
- gfc_ref *ref;
- for (ref = lvalue->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.codimen)
- {
- gfc_error ("Pointer object at %L shall not have a coindex",
- &lvalue->where);
- return false;
- }
- }
-
- /* Checks on rvalue for procedure pointer assignments. */
- if (proc_pointer)
- {
- char err[200];
- gfc_symbol *s1,*s2;
- gfc_component *comp1, *comp2;
- const char *name;
-
- attr = gfc_expr_attr (rvalue);
- if (!((rvalue->expr_type == EXPR_NULL)
- || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
- || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
- || (rvalue->expr_type == EXPR_VARIABLE
- && attr.flavor == FL_PROCEDURE)))
- {
- gfc_error ("Invalid procedure pointer assignment at %L",
- &rvalue->where);
- return false;
- }
-
- if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer)
- {
- /* Check for intrinsics. */
- gfc_symbol *sym = rvalue->symtree->n.sym;
- if (!sym->attr.intrinsic
- && (gfc_is_intrinsic (sym, 0, sym->declared_at)
- || gfc_is_intrinsic (sym, 1, sym->declared_at)))
- {
- sym->attr.intrinsic = 1;
- gfc_resolve_intrinsic (sym, &rvalue->where);
- attr = gfc_expr_attr (rvalue);
- }
- /* Check for result of embracing function. */
- if (sym->attr.function && sym->result == sym)
- {
- gfc_namespace *ns;
-
- for (ns = gfc_current_ns; ns; ns = ns->parent)
- if (sym == ns->proc_name)
- {
- gfc_error ("Function result %qs is invalid as proc-target "
- "in procedure pointer assignment at %L",
- sym->name, &rvalue->where);
- return false;
- }
- }
- }
- if (attr.abstract)
- {
- gfc_error ("Abstract interface %qs is invalid "
- "in procedure pointer assignment at %L",
- rvalue->symtree->name, &rvalue->where);
- return false;
- }
- /* Check for F08:C729. */
- if (attr.flavor == FL_PROCEDURE)
- {
- if (attr.proc == PROC_ST_FUNCTION)
- {
- gfc_error ("Statement function %qs is invalid "
- "in procedure pointer assignment at %L",
- rvalue->symtree->name, &rvalue->where);
- return false;
- }
- if (attr.proc == PROC_INTERNAL &&
- !gfc_notify_std(GFC_STD_F2008, "Internal procedure %qs "
- "is invalid in procedure pointer assignment "
- "at %L", rvalue->symtree->name, &rvalue->where))
- return false;
- if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name,
- attr.subroutine) == 0)
- {
- gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
- "assignment", rvalue->symtree->name, &rvalue->where);
- return false;
- }
- }
- /* Check for F08:C730. */
- if (attr.elemental && !attr.intrinsic)
- {
- gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
- "in procedure pointer assignment at %L",
- rvalue->symtree->name, &rvalue->where);
- return false;
- }
-
- /* Ensure that the calling convention is the same. As other attributes
- such as DLLEXPORT may differ, one explicitly only tests for the
- calling conventions. */
- if (rvalue->expr_type == EXPR_VARIABLE
- && lvalue->symtree->n.sym->attr.ext_attr
- != rvalue->symtree->n.sym->attr.ext_attr)
- {
- symbol_attribute calls;
-
- calls.ext_attr = 0;
- gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL);
- gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL);
- gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL);
-
- if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr)
- != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr))
- {
- gfc_error ("Mismatch in the procedure pointer assignment "
- "at %L: mismatch in the calling convention",
- &rvalue->where);
- return false;
- }
- }
-
- comp1 = gfc_get_proc_ptr_comp (lvalue);
- if (comp1)
- s1 = comp1->ts.interface;
- else
- {
- s1 = lvalue->symtree->n.sym;
- if (s1->ts.interface)
- s1 = s1->ts.interface;
- }
-
- comp2 = gfc_get_proc_ptr_comp (rvalue);
- if (comp2)
- {
- if (rvalue->expr_type == EXPR_FUNCTION)
- {
- s2 = comp2->ts.interface->result;
- name = s2->name;
- }
- else
- {
- s2 = comp2->ts.interface;
- name = comp2->name;
- }
- }
- else if (rvalue->expr_type == EXPR_FUNCTION)
- {
- if (rvalue->value.function.esym)
- s2 = rvalue->value.function.esym->result;
- else
- s2 = rvalue->symtree->n.sym->result;
-
- name = s2->name;
- }
- else
- {
- s2 = rvalue->symtree->n.sym;
- name = s2->name;
- }
-
- if (s2 && s2->attr.proc_pointer && s2->ts.interface)
- s2 = s2->ts.interface;
-
- /* Special check for the case of absent interface on the lvalue.
- * All other interface checks are done below. */
- if (!s1 && comp1 && comp1->attr.subroutine && s2 && s2->attr.function)
- {
- gfc_error ("Interface mismatch in procedure pointer assignment "
- "at %L: %qs is not a subroutine", &rvalue->where, name);
- return false;
- }
-
- /* F08:7.2.2.4 (4) */
- if (s2 && gfc_explicit_interface_required (s2, err, sizeof(err)))
- {
- if (comp1 && !s1)
- {
- gfc_error ("Explicit interface required for component %qs at %L: %s",
- comp1->name, &lvalue->where, err);
- return false;
- }
- else if (s1->attr.if_source == IFSRC_UNKNOWN)
- {
- gfc_error ("Explicit interface required for %qs at %L: %s",
- s1->name, &lvalue->where, err);
- return false;
- }
- }
- if (s1 && gfc_explicit_interface_required (s1, err, sizeof(err)))
- {
- if (comp2 && !s2)
- {
- gfc_error ("Explicit interface required for component %qs at %L: %s",
- comp2->name, &rvalue->where, err);
- return false;
- }
- else if (s2->attr.if_source == IFSRC_UNKNOWN)
- {
- gfc_error ("Explicit interface required for %qs at %L: %s",
- s2->name, &rvalue->where, err);
- return false;
- }
- }
-
- if (s1 == s2 || !s1 || !s2)
- return true;
-
- if (!gfc_compare_interfaces (s1, s2, name, 0, 1,
- err, sizeof(err), NULL, NULL))
- {
- gfc_error ("Interface mismatch in procedure pointer assignment "
- "at %L: %s", &rvalue->where, err);
- return false;
- }
-
- /* Check F2008Cor2, C729. */
- if (!s2->attr.intrinsic && s2->attr.if_source == IFSRC_UNKNOWN
- && !s2->attr.external && !s2->attr.subroutine && !s2->attr.function)
- {
- gfc_error ("Procedure pointer target %qs at %L must be either an "
- "intrinsic, host or use associated, referenced or have "
- "the EXTERNAL attribute", s2->name, &rvalue->where);
- return false;
- }
-
- return true;
- }
- else
- {
- /* A non-proc pointer cannot point to a constant. */
- if (rvalue->expr_type == EXPR_CONSTANT)
- {
- gfc_error_now ("Pointer assignment target cannot be a constant at %L",
- &rvalue->where);
- return false;
- }
- }
-
- if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
- {
- /* Check for F03:C717. */
- if (UNLIMITED_POLY (rvalue)
- && !(UNLIMITED_POLY (lvalue)
- || (lvalue->ts.type == BT_DERIVED
- && (lvalue->ts.u.derived->attr.is_bind_c
- || lvalue->ts.u.derived->attr.sequence))))
- gfc_error ("Data-pointer-object at %L must be unlimited "
- "polymorphic, or of a type with the BIND or SEQUENCE "
- "attribute, to be compatible with an unlimited "
- "polymorphic target", &lvalue->where);
- else if (!suppress_type_test)
- gfc_error ("Different types in pointer assignment at %L; "
- "attempted assignment of %s to %s", &lvalue->where,
- gfc_typename (rvalue), gfc_typename (lvalue));
- return false;
- }
-
- if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
- {
- gfc_error ("Different kind type parameters in pointer "
- "assignment at %L", &lvalue->where);
- return false;
- }
-
- if (lvalue->rank != rvalue->rank && !rank_remap)
- {
- gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where);
- return false;
- }
-
- /* Make sure the vtab is present. */
- if (lvalue->ts.type == BT_CLASS && !UNLIMITED_POLY (rvalue))
- gfc_find_vtab (&rvalue->ts);
-
- /* Check rank remapping. */
- if (rank_remap)
- {
- mpz_t lsize, rsize;
-
- /* If this can be determined, check that the target must be at least as
- large as the pointer assigned to it is. */
- if (gfc_array_size (lvalue, &lsize)
- && gfc_array_size (rvalue, &rsize)
- && mpz_cmp (rsize, lsize) < 0)
- {
- gfc_error ("Rank remapping target is smaller than size of the"
- " pointer (%ld < %ld) at %L",
- mpz_get_si (rsize), mpz_get_si (lsize),
- &lvalue->where);
- return false;
- }
-
- /* The target must be either rank one or it must be simply contiguous
- and F2008 must be allowed. */
- if (rvalue->rank != 1)
- {
- if (!gfc_is_simply_contiguous (rvalue, true, false))
- {
- gfc_error ("Rank remapping target must be rank 1 or"
- " simply contiguous at %L", &rvalue->where);
- return false;
- }
- if (!gfc_notify_std (GFC_STD_F2008, "Rank remapping target is not "
- "rank 1 at %L", &rvalue->where))
- return false;
- }
- }
-
- /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
- if (rvalue->expr_type == EXPR_NULL)
- return true;
-
- if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
- lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
-
- attr = gfc_expr_attr (rvalue);
-
- if (rvalue->expr_type == EXPR_FUNCTION && !attr.pointer)
- {
- /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call
- to caf_get. Map this to the same error message as below when it is
- still a variable expression. */
- if (rvalue->value.function.isym
- && rvalue->value.function.isym->id == GFC_ISYM_CAF_GET)
- /* The test above might need to be extend when F08, Note 5.4 has to be
- interpreted in the way that target and pointer with the same coindex
- are allowed. */
- gfc_error ("Data target at %L shall not have a coindex",
- &rvalue->where);
- else
- gfc_error ("Target expression in pointer assignment "
- "at %L must deliver a pointer result",
- &rvalue->where);
- return false;
- }
-
- if (is_init_expr)
- {
- gfc_symbol *sym;
- bool target;
- gfc_ref *ref;
-
- if (gfc_is_size_zero_array (rvalue))
- {
- gfc_error ("Zero-sized array detected at %L where an entity with "
- "the TARGET attribute is expected", &rvalue->where);
- return false;
- }
- else if (!rvalue->symtree)
- {
- gfc_error ("Pointer assignment target in initialization expression "
- "does not have the TARGET attribute at %L",
- &rvalue->where);
- return false;
- }
-
- sym = rvalue->symtree->n.sym;
-
- if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
- target = CLASS_DATA (sym)->attr.target;
- else
- target = sym->attr.target;
-
- if (!target && !proc_pointer)
- {
- gfc_error ("Pointer assignment target in initialization expression "
- "does not have the TARGET attribute at %L",
- &rvalue->where);
- return false;
- }
-
- for (ref = rvalue->ref; ref; ref = ref->next)
- {
- switch (ref->type)
- {
- case REF_ARRAY:
- for (int n = 0; n < ref->u.ar.dimen; n++)
- if (!gfc_is_constant_expr (ref->u.ar.start[n])
- || !gfc_is_constant_expr (ref->u.ar.end[n])
- || !gfc_is_constant_expr (ref->u.ar.stride[n]))
- {
- gfc_error ("Every subscript of target specification "
- "at %L must be a constant expression",
- &ref->u.ar.where);
- return false;
- }
- break;
-
- case REF_SUBSTRING:
- if (!gfc_is_constant_expr (ref->u.ss.start)
- || !gfc_is_constant_expr (ref->u.ss.end))
- {
- gfc_error ("Substring starting and ending points of target "
- "specification at %L must be constant expressions",
- &ref->u.ss.start->where);
- return false;
- }
- break;
-
- default:
- break;
- }
- }
- }
- else
- {
- if (!attr.target && !attr.pointer)
- {
- gfc_error ("Pointer assignment target is neither TARGET "
- "nor POINTER at %L", &rvalue->where);
- return false;
- }
- }
-
- if (lvalue->ts.type == BT_CHARACTER)
- {
- bool t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
- if (!t)
- return false;
- }
-
- if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
- {
- gfc_error ("Bad target in pointer assignment in PURE "
- "procedure at %L", &rvalue->where);
- }
-
- if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym))
- gfc_unset_implicit_pure (gfc_current_ns->proc_name);
-
- if (gfc_has_vector_index (rvalue))
- {
- gfc_error ("Pointer assignment with vector subscript "
- "on rhs at %L", &rvalue->where);
- return false;
- }
-
- if (attr.is_protected && attr.use_assoc
- && !(attr.pointer || attr.proc_pointer))
- {
- gfc_error ("Pointer assignment target has PROTECTED "
- "attribute at %L", &rvalue->where);
- return false;
- }
-
- /* F2008, C725. For PURE also C1283. */
- if (rvalue->expr_type == EXPR_VARIABLE
- && gfc_is_coindexed (rvalue))
- {
- gfc_ref *ref;
- for (ref = rvalue->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.codimen)
- {
- gfc_error ("Data target at %L shall not have a coindex",
- &rvalue->where);
- return false;
- }
- }
-
- /* Warn for assignments of contiguous pointers to targets which is not
- contiguous. Be lenient in the definition of what counts as
- contiguous. */
-
- if (lhs_attr.contiguous
- && lhs_attr.dimension > 0)
- {
- if (gfc_is_not_contiguous (rvalue))
- {
- gfc_error ("Assignment to contiguous pointer from "
- "non-contiguous target at %L", &rvalue->where);
- return false;
- }
- if (!gfc_is_simply_contiguous (rvalue, false, true))
- gfc_warning (OPT_Wextra, "Assignment to contiguous pointer from "
- "non-contiguous target at %L", &rvalue->where);
- }
-
- /* Warn if it is the LHS pointer may lives longer than the RHS target. */
- if (warn_target_lifetime
- && rvalue->expr_type == EXPR_VARIABLE
- && !rvalue->symtree->n.sym->attr.save
- && !rvalue->symtree->n.sym->attr.pointer && !attr.pointer
- && !rvalue->symtree->n.sym->attr.host_assoc
- && !rvalue->symtree->n.sym->attr.in_common
- && !rvalue->symtree->n.sym->attr.use_assoc
- && !rvalue->symtree->n.sym->attr.dummy)
- {
- bool warn;
- gfc_namespace *ns;
-
- warn = lvalue->symtree->n.sym->attr.dummy
- || lvalue->symtree->n.sym->attr.result
- || lvalue->symtree->n.sym->attr.function
- || (lvalue->symtree->n.sym->attr.host_assoc
- && lvalue->symtree->n.sym->ns
- != rvalue->symtree->n.sym->ns)
- || lvalue->symtree->n.sym->attr.use_assoc
- || lvalue->symtree->n.sym->attr.in_common;
-
- if (rvalue->symtree->n.sym->ns->proc_name
- && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROCEDURE
- && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROGRAM)
- for (ns = rvalue->symtree->n.sym->ns;
- ns && ns->proc_name && ns->proc_name->attr.flavor != FL_PROCEDURE;
- ns = ns->parent)
- if (ns->parent == lvalue->symtree->n.sym->ns)
- {
- warn = true;
- break;
- }
-
- if (warn)
- gfc_warning (OPT_Wtarget_lifetime,
- "Pointer at %L in pointer assignment might outlive the "
- "pointer target", &lvalue->where);
- }
-
- return true;
-}
-
-
-/* Relative of gfc_check_assign() except that the lvalue is a single
- symbol. Used for initialization assignments. */
-
-bool
-gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue)
-{
- gfc_expr lvalue;
- bool r;
- bool pointer, proc_pointer;
-
- memset (&lvalue, '\0', sizeof (gfc_expr));
-
- lvalue.expr_type = EXPR_VARIABLE;
- lvalue.ts = sym->ts;
- if (sym->as)
- lvalue.rank = sym->as->rank;
- lvalue.symtree = XCNEW (gfc_symtree);
- lvalue.symtree->n.sym = sym;
- lvalue.where = sym->declared_at;
-
- if (comp)
- {
- lvalue.ref = gfc_get_ref ();
- lvalue.ref->type = REF_COMPONENT;
- lvalue.ref->u.c.component = comp;
- lvalue.ref->u.c.sym = sym;
- lvalue.ts = comp->ts;
- lvalue.rank = comp->as ? comp->as->rank : 0;
- lvalue.where = comp->loc;
- pointer = comp->ts.type == BT_CLASS && CLASS_DATA (comp)
- ? CLASS_DATA (comp)->attr.class_pointer : comp->attr.pointer;
- proc_pointer = comp->attr.proc_pointer;
- }
- else
- {
- pointer = sym->ts.type == BT_CLASS && CLASS_DATA (sym)
- ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer;
- proc_pointer = sym->attr.proc_pointer;
- }
-
- if (pointer || proc_pointer)
- r = gfc_check_pointer_assign (&lvalue, rvalue, false, true);
- else
- {
- /* If a conversion function, e.g., __convert_i8_i4, was inserted
- into an array constructor, we should check if it can be reduced
- as an initialization expression. */
- if (rvalue->expr_type == EXPR_FUNCTION
- && rvalue->value.function.isym
- && (rvalue->value.function.isym->conversion == 1))
- gfc_check_init_expr (rvalue);
-
- r = gfc_check_assign (&lvalue, rvalue, 1);
- }
-
- free (lvalue.symtree);
- free (lvalue.ref);
-
- if (!r)
- return r;
-
- if (pointer && rvalue->expr_type != EXPR_NULL && !proc_pointer)
- {
- /* F08:C461. Additional checks for pointer initialization. */
- symbol_attribute attr;
- attr = gfc_expr_attr (rvalue);
- if (attr.allocatable)
- {
- gfc_error ("Pointer initialization target at %L "
- "must not be ALLOCATABLE", &rvalue->where);
- return false;
- }
- if (!attr.target || attr.pointer)
- {
- gfc_error ("Pointer initialization target at %L "
- "must have the TARGET attribute", &rvalue->where);
- return false;
- }
-
- if (!attr.save && rvalue->expr_type == EXPR_VARIABLE
- && rvalue->symtree->n.sym->ns->proc_name
- && rvalue->symtree->n.sym->ns->proc_name->attr.is_main_program)
- {
- rvalue->symtree->n.sym->ns->proc_name->attr.save = SAVE_IMPLICIT;
- attr.save = SAVE_IMPLICIT;
- }
-
- if (!attr.save)
- {
- gfc_error ("Pointer initialization target at %L "
- "must have the SAVE attribute", &rvalue->where);
- return false;
- }
- }
-
- if (proc_pointer && rvalue->expr_type != EXPR_NULL)
- {
- /* F08:C1220. Additional checks for procedure pointer initialization. */
- symbol_attribute attr = gfc_expr_attr (rvalue);
- if (attr.proc_pointer)
- {
- gfc_error ("Procedure pointer initialization target at %L "
- "may not be a procedure pointer", &rvalue->where);
- return false;
- }
- if (attr.proc == PROC_INTERNAL)
- {
- gfc_error ("Internal procedure %qs is invalid in "
- "procedure pointer initialization at %L",
- rvalue->symtree->name, &rvalue->where);
- return false;
- }
- if (attr.dummy)
- {
- gfc_error ("Dummy procedure %qs is invalid in "
- "procedure pointer initialization at %L",
- rvalue->symtree->name, &rvalue->where);
- return false;
- }
- }
-
- return true;
-}
-
-/* Build an initializer for a local integer, real, complex, logical, or
- character variable, based on the command line flags finit-local-zero,
- finit-integer=, finit-real=, finit-logical=, and finit-character=.
- With force, an initializer is ALWAYS generated. */
-
-static gfc_expr *
-gfc_build_init_expr (gfc_typespec *ts, locus *where, bool force)
-{
- gfc_expr *init_expr;
-
- /* Try to build an initializer expression. */
- init_expr = gfc_get_constant_expr (ts->type, ts->kind, where);
-
- /* If we want to force generation, make sure we default to zero. */
- gfc_init_local_real init_real = flag_init_real;
- int init_logical = gfc_option.flag_init_logical;
- if (force)
- {
- if (init_real == GFC_INIT_REAL_OFF)
- init_real = GFC_INIT_REAL_ZERO;
- if (init_logical == GFC_INIT_LOGICAL_OFF)
- init_logical = GFC_INIT_LOGICAL_FALSE;
- }
-
- /* We will only initialize integers, reals, complex, logicals, and
- characters, and only if the corresponding command-line flags
- were set. Otherwise, we free init_expr and return null. */
- switch (ts->type)
- {
- case BT_INTEGER:
- if (force || gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
- mpz_set_si (init_expr->value.integer,
- gfc_option.flag_init_integer_value);
- else
- {
- gfc_free_expr (init_expr);
- init_expr = NULL;
- }
- break;
-
- case BT_REAL:
- switch (init_real)
- {
- case GFC_INIT_REAL_SNAN:
- init_expr->is_snan = 1;
- /* Fall through. */
- case GFC_INIT_REAL_NAN:
- mpfr_set_nan (init_expr->value.real);
- break;
-
- case GFC_INIT_REAL_INF:
- mpfr_set_inf (init_expr->value.real, 1);
- break;
-
- case GFC_INIT_REAL_NEG_INF:
- mpfr_set_inf (init_expr->value.real, -1);
- break;
-
- case GFC_INIT_REAL_ZERO:
- mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
- break;
-
- default:
- gfc_free_expr (init_expr);
- init_expr = NULL;
- break;
- }
- break;
-
- case BT_COMPLEX:
- switch (init_real)
- {
- case GFC_INIT_REAL_SNAN:
- init_expr->is_snan = 1;
- /* Fall through. */
- case GFC_INIT_REAL_NAN:
- mpfr_set_nan (mpc_realref (init_expr->value.complex));
- mpfr_set_nan (mpc_imagref (init_expr->value.complex));
- break;
-
- case GFC_INIT_REAL_INF:
- mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
- mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
- break;
-
- case GFC_INIT_REAL_NEG_INF:
- mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
- mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
- break;
-
- case GFC_INIT_REAL_ZERO:
- mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
- break;
-
- default:
- gfc_free_expr (init_expr);
- init_expr = NULL;
- break;
- }
- break;
-
- case BT_LOGICAL:
- if (init_logical == GFC_INIT_LOGICAL_FALSE)
- init_expr->value.logical = 0;
- else if (init_logical == GFC_INIT_LOGICAL_TRUE)
- init_expr->value.logical = 1;
- else
- {
- gfc_free_expr (init_expr);
- init_expr = NULL;
- }
- break;
-
- case BT_CHARACTER:
- /* For characters, the length must be constant in order to
- create a default initializer. */
- if ((force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON)
- && ts->u.cl->length
- && ts->u.cl->length->expr_type == EXPR_CONSTANT)
- {
- HOST_WIDE_INT char_len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
- init_expr->value.character.length = char_len;
- init_expr->value.character.string = gfc_get_wide_string (char_len+1);
- for (size_t i = 0; i < (size_t) char_len; i++)
- init_expr->value.character.string[i]
- = (unsigned char) gfc_option.flag_init_character_value;
- }
- else
- {
- gfc_free_expr (init_expr);
- init_expr = NULL;
- }
- if (!init_expr
- && (force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON)
- && ts->u.cl->length && flag_max_stack_var_size != 0)
- {
- gfc_actual_arglist *arg;
- init_expr = gfc_get_expr ();
- init_expr->where = *where;
- init_expr->ts = *ts;
- init_expr->expr_type = EXPR_FUNCTION;
- init_expr->value.function.isym =
- gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT);
- init_expr->value.function.name = "repeat";
- arg = gfc_get_actual_arglist ();
- arg->expr = gfc_get_character_expr (ts->kind, where, NULL, 1);
- arg->expr->value.character.string[0] =
- gfc_option.flag_init_character_value;
- arg->next = gfc_get_actual_arglist ();
- arg->next->expr = gfc_copy_expr (ts->u.cl->length);
- init_expr->value.function.actual = arg;
- }
- break;
-
- default:
- gfc_free_expr (init_expr);
- init_expr = NULL;
- }
-
- return init_expr;
-}
-
-/* Invoke gfc_build_init_expr to create an initializer expression, but do not
- * require that an expression be built. */
-
-gfc_expr *
-gfc_build_default_init_expr (gfc_typespec *ts, locus *where)
-{
- return gfc_build_init_expr (ts, where, false);
-}
-
-/* Apply an initialization expression to a typespec. Can be used for symbols or
- components. Similar to add_init_expr_to_sym in decl.c; could probably be
- combined with some effort. */
-
-void
-gfc_apply_init (gfc_typespec *ts, symbol_attribute *attr, gfc_expr *init)
-{
- if (ts->type == BT_CHARACTER && !attr->pointer && init
- && ts->u.cl
- && ts->u.cl->length
- && ts->u.cl->length->expr_type == EXPR_CONSTANT
- && ts->u.cl->length->ts.type == BT_INTEGER)
- {
- HOST_WIDE_INT len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
-
- if (init->expr_type == EXPR_CONSTANT)
- gfc_set_constant_character_len (len, init, -1);
- else if (init
- && init->ts.type == BT_CHARACTER
- && init->ts.u.cl && init->ts.u.cl->length
- && mpz_cmp (ts->u.cl->length->value.integer,
- init->ts.u.cl->length->value.integer))
- {
- gfc_constructor *ctor;
- ctor = gfc_constructor_first (init->value.constructor);
-
- if (ctor)
- {
- bool has_ts = (init->ts.u.cl
- && init->ts.u.cl->length_from_typespec);
-
- /* Remember the length of the first element for checking
- that all elements *in the constructor* have the same
- length. This need not be the length of the LHS! */
- gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT);
- gcc_assert (ctor->expr->ts.type == BT_CHARACTER);
- gfc_charlen_t first_len = ctor->expr->value.character.length;
-
- for ( ; ctor; ctor = gfc_constructor_next (ctor))
- if (ctor->expr->expr_type == EXPR_CONSTANT)
- {
- gfc_set_constant_character_len (len, ctor->expr,
- has_ts ? -1 : first_len);
- if (!ctor->expr->ts.u.cl)
- ctor->expr->ts.u.cl
- = gfc_new_charlen (gfc_current_ns, ts->u.cl);
- else
- ctor->expr->ts.u.cl->length
- = gfc_copy_expr (ts->u.cl->length);
- }
- }
- }
- }
-}
-
-
-/* Check whether an expression is a structure constructor and whether it has
- other values than NULL. */
-
-static bool
-is_non_empty_structure_constructor (gfc_expr * e)
-{
- if (e->expr_type != EXPR_STRUCTURE)
- return false;
-
- gfc_constructor *cons = gfc_constructor_first (e->value.constructor);
- while (cons)
- {
- if (!cons->expr || cons->expr->expr_type != EXPR_NULL)
- return true;
- cons = gfc_constructor_next (cons);
- }
- return false;
-}
-
-
-/* Check for default initializer; sym->value is not enough
- as it is also set for EXPR_NULL of allocatables. */
-
-bool
-gfc_has_default_initializer (gfc_symbol *der)
-{
- gfc_component *c;
-
- gcc_assert (gfc_fl_struct (der->attr.flavor));
- for (c = der->components; c; c = c->next)
- if (gfc_bt_struct (c->ts.type))
- {
- if (!c->attr.pointer && !c->attr.proc_pointer
- && !(c->attr.allocatable && der == c->ts.u.derived)
- && ((c->initializer
- && is_non_empty_structure_constructor (c->initializer))
- || gfc_has_default_initializer (c->ts.u.derived)))
- return true;
- if (c->attr.pointer && c->initializer)
- return true;
- }
- else
- {
- if (c->initializer)
- return true;
- }
-
- return false;
-}
-
-
-/*
- Generate an initializer expression which initializes the entirety of a union.
- A normal structure constructor is insufficient without undue effort, because
- components of maps may be oddly aligned/overlapped. (For example if a
- character is initialized from one map overtop a real from the other, only one
- byte of the real is actually initialized.) Unfortunately we don't know the
- size of the union right now, so we can't generate a proper initializer, but
- we use a NULL expr as a placeholder and do the right thing later in
- gfc_trans_subcomponent_assign.
- */
-static gfc_expr *
-generate_union_initializer (gfc_component *un)
-{
- if (un == NULL || un->ts.type != BT_UNION)
- return NULL;
-
- gfc_expr *placeholder = gfc_get_null_expr (&un->loc);
- placeholder->ts = un->ts;
- return placeholder;
-}
-
-
-/* Get the user-specified initializer for a union, if any. This means the user
- has said to initialize component(s) of a map. For simplicity's sake we
- only allow the user to initialize the first map. We don't have to worry
- about overlapping initializers as they are released early in resolution (see
- resolve_fl_struct). */
-
-static gfc_expr *
-get_union_initializer (gfc_symbol *union_type, gfc_component **map_p)
-{
- gfc_component *map;
- gfc_expr *init=NULL;
-
- if (!union_type || union_type->attr.flavor != FL_UNION)
- return NULL;
-
- for (map = union_type->components; map; map = map->next)
- {
- if (gfc_has_default_initializer (map->ts.u.derived))
- {
- init = gfc_default_initializer (&map->ts);
- if (map_p)
- *map_p = map;
- break;
- }
- }
-
- if (map_p && !init)
- *map_p = NULL;
-
- return init;
-}
-
-static bool
-class_allocatable (gfc_component *comp)
-{
- return comp->ts.type == BT_CLASS && CLASS_DATA (comp)
- && CLASS_DATA (comp)->attr.allocatable;
-}
-
-static bool
-class_pointer (gfc_component *comp)
-{
- return comp->ts.type == BT_CLASS && CLASS_DATA (comp)
- && CLASS_DATA (comp)->attr.pointer;
-}
-
-static bool
-comp_allocatable (gfc_component *comp)
-{
- return comp->attr.allocatable || class_allocatable (comp);
-}
-
-static bool
-comp_pointer (gfc_component *comp)
-{
- return comp->attr.pointer
- || comp->attr.proc_pointer
- || comp->attr.class_pointer
- || class_pointer (comp);
-}
-
-/* Fetch or generate an initializer for the given component.
- Only generate an initializer if generate is true. */
-
-static gfc_expr *
-component_initializer (gfc_component *c, bool generate)
-{
- gfc_expr *init = NULL;
-
- /* Allocatable components always get EXPR_NULL.
- Pointer components are only initialized when generating, and only if they
- do not already have an initializer. */
- if (comp_allocatable (c) || (generate && comp_pointer (c) && !c->initializer))
- {
- init = gfc_get_null_expr (&c->loc);
- init->ts = c->ts;
- return init;
- }
-
- /* See if we can find the initializer immediately. */
- if (c->initializer || !generate)
- return c->initializer;
-
- /* Recursively handle derived type components. */
- else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
- init = gfc_generate_initializer (&c->ts, true);
-
- else if (c->ts.type == BT_UNION && c->ts.u.derived->components)
- {
- gfc_component *map = NULL;
- gfc_constructor *ctor;
- gfc_expr *user_init;
-
- /* If we don't have a user initializer and we aren't generating one, this
- union has no initializer. */
- user_init = get_union_initializer (c->ts.u.derived, &map);
- if (!user_init && !generate)
- return NULL;
-
- /* Otherwise use a structure constructor. */
- init = gfc_get_structure_constructor_expr (c->ts.type, c->ts.kind,
- &c->loc);
- init->ts = c->ts;
-
- /* If we are to generate an initializer for the union, add a constructor
- which initializes the whole union first. */
- if (generate)
- {
- ctor = gfc_constructor_get ();
- ctor->expr = generate_union_initializer (c);
- gfc_constructor_append (&init->value.constructor, ctor);
- }
-
- /* If we found an initializer in one of our maps, apply it. Note this
- is applied _after_ the entire-union initializer above if any. */
- if (user_init)
- {
- ctor = gfc_constructor_get ();
- ctor->expr = user_init;
- ctor->n.component = map;
- gfc_constructor_append (&init->value.constructor, ctor);
- }
- }
-
- /* Treat simple components like locals. */
- else
- {
- /* We MUST give an initializer, so force generation. */
- init = gfc_build_init_expr (&c->ts, &c->loc, true);
- gfc_apply_init (&c->ts, &c->attr, init);
- }
-
- return init;
-}
-
-
-/* Get an expression for a default initializer of a derived type. */
-
-gfc_expr *
-gfc_default_initializer (gfc_typespec *ts)
-{
- return gfc_generate_initializer (ts, false);
-}
-
-/* Generate an initializer expression for an iso_c_binding type
- such as c_[fun]ptr. The appropriate initializer is c_null_[fun]ptr. */
-
-static gfc_expr *
-generate_isocbinding_initializer (gfc_symbol *derived)
-{
- /* The initializers have already been built into the c_null_[fun]ptr symbols
- from gen_special_c_interop_ptr. */
- gfc_symtree *npsym = NULL;
- if (0 == strcmp (derived->name, "c_ptr"))
- gfc_find_sym_tree ("c_null_ptr", gfc_current_ns, true, &npsym);
- else if (0 == strcmp (derived->name, "c_funptr"))
- gfc_find_sym_tree ("c_null_funptr", gfc_current_ns, true, &npsym);
- else
- gfc_internal_error ("generate_isocbinding_initializer(): bad iso_c_binding"
- " type, expected %<c_ptr%> or %<c_funptr%>");
- if (npsym)
- {
- gfc_expr *init = gfc_copy_expr (npsym->n.sym->value);
- init->symtree = npsym;
- init->ts.is_iso_c = true;
- return init;
- }
-
- return NULL;
-}
-
-/* Get or generate an expression for a default initializer of a derived type.
- If -finit-derived is specified, generate default initialization expressions
- for components that lack them when generate is set. */
-
-gfc_expr *
-gfc_generate_initializer (gfc_typespec *ts, bool generate)
-{
- gfc_expr *init, *tmp;
- gfc_component *comp;
-
- generate = flag_init_derived && generate;
-
- if (ts->u.derived->ts.is_iso_c && generate)
- return generate_isocbinding_initializer (ts->u.derived);
-
- /* See if we have a default initializer in this, but not in nested
- types (otherwise we could use gfc_has_default_initializer()).
- We don't need to check if we are going to generate them. */
- comp = ts->u.derived->components;
- if (!generate)
- {
- for (; comp; comp = comp->next)
- if (comp->initializer || comp_allocatable (comp))
- break;
- }
-
- if (!comp)
- return NULL;
-
- init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
- &ts->u.derived->declared_at);
- init->ts = *ts;
-
- for (comp = ts->u.derived->components; comp; comp = comp->next)
- {
- gfc_constructor *ctor = gfc_constructor_get();
-
- /* Fetch or generate an initializer for the component. */
- tmp = component_initializer (comp, generate);
- if (tmp)
- {
- /* Save the component ref for STRUCTUREs and UNIONs. */
- if (ts->u.derived->attr.flavor == FL_STRUCT
- || ts->u.derived->attr.flavor == FL_UNION)
- ctor->n.component = comp;
-
- /* If the initializer was not generated, we need a copy. */
- ctor->expr = comp->initializer ? gfc_copy_expr (tmp) : tmp;
- if ((comp->ts.type != tmp->ts.type || comp->ts.kind != tmp->ts.kind)
- && !comp->attr.pointer && !comp->attr.proc_pointer)
- {
- bool val;
- val = gfc_convert_type_warn (ctor->expr, &comp->ts, 1, false);
- if (val == false)
- return NULL;
- }
- }
-
- gfc_constructor_append (&init->value.constructor, ctor);
- }
-
- return init;
-}
-
-
-/* Given a symbol, create an expression node with that symbol as a
- variable. If the symbol is array valued, setup a reference of the
- whole array. */
-
-gfc_expr *
-gfc_get_variable_expr (gfc_symtree *var)
-{
- gfc_expr *e;
-
- e = gfc_get_expr ();
- e->expr_type = EXPR_VARIABLE;
- e->symtree = var;
- e->ts = var->n.sym->ts;
-
- if (var->n.sym->attr.flavor != FL_PROCEDURE
- && ((var->n.sym->as != NULL && var->n.sym->ts.type != BT_CLASS)
- || (var->n.sym->ts.type == BT_CLASS && var->n.sym->ts.u.derived
- && CLASS_DATA (var->n.sym)
- && CLASS_DATA (var->n.sym)->as)))
- {
- e->rank = var->n.sym->ts.type == BT_CLASS
- ? CLASS_DATA (var->n.sym)->as->rank : var->n.sym->as->rank;
- e->ref = gfc_get_ref ();
- e->ref->type = REF_ARRAY;
- e->ref->u.ar.type = AR_FULL;
- e->ref->u.ar.as = gfc_copy_array_spec (var->n.sym->ts.type == BT_CLASS
- ? CLASS_DATA (var->n.sym)->as
- : var->n.sym->as);
- }
-
- return e;
-}
-
-
-/* Adds a full array reference to an expression, as needed. */
-
-void
-gfc_add_full_array_ref (gfc_expr *e, gfc_array_spec *as)
-{
- gfc_ref *ref;
- for (ref = e->ref; ref; ref = ref->next)
- if (!ref->next)
- break;
- if (ref)
- {
- ref->next = gfc_get_ref ();
- ref = ref->next;
- }
- else
- {
- e->ref = gfc_get_ref ();
- ref = e->ref;
- }
- ref->type = REF_ARRAY;
- ref->u.ar.type = AR_FULL;
- ref->u.ar.dimen = e->rank;
- ref->u.ar.where = e->where;
- ref->u.ar.as = as;
-}
-
-
-gfc_expr *
-gfc_lval_expr_from_sym (gfc_symbol *sym)
-{
- gfc_expr *lval;
- gfc_array_spec *as;
- lval = gfc_get_expr ();
- lval->expr_type = EXPR_VARIABLE;
- lval->where = sym->declared_at;
- lval->ts = sym->ts;
- lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
-
- /* It will always be a full array. */
- as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
- lval->rank = as ? as->rank : 0;
- if (lval->rank)
- gfc_add_full_array_ref (lval, as);
- return lval;
-}
-
-
-/* Returns the array_spec of a full array expression. A NULL is
- returned otherwise. */
-gfc_array_spec *
-gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
-{
- gfc_array_spec *as;
- gfc_ref *ref;
-
- if (expr->rank == 0)
- return NULL;
-
- /* Follow any component references. */
- if (expr->expr_type == EXPR_VARIABLE
- || expr->expr_type == EXPR_CONSTANT)
- {
- if (expr->symtree)
- as = expr->symtree->n.sym->as;
- else
- as = NULL;
-
- for (ref = expr->ref; ref; ref = ref->next)
- {
- switch (ref->type)
- {
- case REF_COMPONENT:
- as = ref->u.c.component->as;
- continue;
-
- case REF_SUBSTRING:
- case REF_INQUIRY:
- continue;
-
- case REF_ARRAY:
- {
- switch (ref->u.ar.type)
- {
- case AR_ELEMENT:
- case AR_SECTION:
- case AR_UNKNOWN:
- as = NULL;
- continue;
-
- case AR_FULL:
- break;
- }
- break;
- }
- }
- }
- }
- else
- as = NULL;
-
- return as;
-}
-
-
-/* General expression traversal function. */
-
-bool
-gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
- bool (*func)(gfc_expr *, gfc_symbol *, int*),
- int f)
-{
- gfc_array_ref ar;
- gfc_ref *ref;
- gfc_actual_arglist *args;
- gfc_constructor *c;
- int i;
-
- if (!expr)
- return false;
-
- if ((*func) (expr, sym, &f))
- return true;
-
- if (expr->ts.type == BT_CHARACTER
- && expr->ts.u.cl
- && expr->ts.u.cl->length
- && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
- && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f))
- return true;
-
- switch (expr->expr_type)
- {
- case EXPR_PPC:
- case EXPR_COMPCALL:
- case EXPR_FUNCTION:
- for (args = expr->value.function.actual; args; args = args->next)
- {
- if (gfc_traverse_expr (args->expr, sym, func, f))
- return true;
- }
- break;
-
- case EXPR_VARIABLE:
- case EXPR_CONSTANT:
- case EXPR_NULL:
- case EXPR_SUBSTRING:
- break;
-
- case EXPR_STRUCTURE:
- case EXPR_ARRAY:
- for (c = gfc_constructor_first (expr->value.constructor);
- c; c = gfc_constructor_next (c))
- {
- if (gfc_traverse_expr (c->expr, sym, func, f))
- return true;
- if (c->iterator)
- {
- if (gfc_traverse_expr (c->iterator->var, sym, func, f))
- return true;
- if (gfc_traverse_expr (c->iterator->start, sym, func, f))
- return true;
- if (gfc_traverse_expr (c->iterator->end, sym, func, f))
- return true;
- if (gfc_traverse_expr (c->iterator->step, sym, func, f))
- return true;
- }
- }
- break;
-
- case EXPR_OP:
- if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
- return true;
- if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
- return true;
- break;
-
- default:
- gcc_unreachable ();
- break;
- }
-
- ref = expr->ref;
- while (ref != NULL)
- {
- switch (ref->type)
- {
- case REF_ARRAY:
- ar = ref->u.ar;
- for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
- {
- if (gfc_traverse_expr (ar.start[i], sym, func, f))
- return true;
- if (gfc_traverse_expr (ar.end[i], sym, func, f))
- return true;
- if (gfc_traverse_expr (ar.stride[i], sym, func, f))
- return true;
- }
- break;
-
- case REF_SUBSTRING:
- if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
- return true;
- if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
- return true;
- break;
-
- case REF_COMPONENT:
- if (ref->u.c.component->ts.type == BT_CHARACTER
- && ref->u.c.component->ts.u.cl
- && ref->u.c.component->ts.u.cl->length
- && ref->u.c.component->ts.u.cl->length->expr_type
- != EXPR_CONSTANT
- && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length,
- sym, func, f))
- return true;
-
- if (ref->u.c.component->as)
- for (i = 0; i < ref->u.c.component->as->rank
- + ref->u.c.component->as->corank; i++)
- {
- if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
- sym, func, f))
- return true;
- if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
- sym, func, f))
- return true;
- }
- break;
-
- case REF_INQUIRY:
- return true;
-
- default:
- gcc_unreachable ();
- }
- ref = ref->next;
- }
- return false;
-}
-
-/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
-
-static bool
-expr_set_symbols_referenced (gfc_expr *expr,
- gfc_symbol *sym ATTRIBUTE_UNUSED,
- int *f ATTRIBUTE_UNUSED)
-{
- if (expr->expr_type != EXPR_VARIABLE)
- return false;
- gfc_set_sym_referenced (expr->symtree->n.sym);
- return false;
-}
-
-void
-gfc_expr_set_symbols_referenced (gfc_expr *expr)
-{
- gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
-}
-
-
-/* Determine if an expression is a procedure pointer component and return
- the component in that case. Otherwise return NULL. */
-
-gfc_component *
-gfc_get_proc_ptr_comp (gfc_expr *expr)
-{
- gfc_ref *ref;
-
- if (!expr || !expr->ref)
- return NULL;
-
- ref = expr->ref;
- while (ref->next)
- ref = ref->next;
-
- if (ref->type == REF_COMPONENT
- && ref->u.c.component->attr.proc_pointer)
- return ref->u.c.component;
-
- return NULL;
-}
-
-
-/* Determine if an expression is a procedure pointer component. */
-
-bool
-gfc_is_proc_ptr_comp (gfc_expr *expr)
-{
- return (gfc_get_proc_ptr_comp (expr) != NULL);
-}
-
-
-/* Determine if an expression is a function with an allocatable class scalar
- result. */
-bool
-gfc_is_alloc_class_scalar_function (gfc_expr *expr)
-{
- if (expr->expr_type == EXPR_FUNCTION
- && expr->value.function.esym
- && expr->value.function.esym->result
- && expr->value.function.esym->result->ts.type == BT_CLASS
- && !CLASS_DATA (expr->value.function.esym->result)->attr.dimension
- && CLASS_DATA (expr->value.function.esym->result)->attr.allocatable)
- return true;
-
- return false;
-}
-
-
-/* Determine if an expression is a function with an allocatable class array
- result. */
-bool
-gfc_is_class_array_function (gfc_expr *expr)
-{
- if (expr->expr_type == EXPR_FUNCTION
- && expr->value.function.esym
- && expr->value.function.esym->result
- && expr->value.function.esym->result->ts.type == BT_CLASS
- && CLASS_DATA (expr->value.function.esym->result)->attr.dimension
- && (CLASS_DATA (expr->value.function.esym->result)->attr.allocatable
- || CLASS_DATA (expr->value.function.esym->result)->attr.pointer))
- return true;
-
- return false;
-}
-
-
-/* Walk an expression tree and check each variable encountered for being typed.
- If strict is not set, a top-level variable is tolerated untyped in -std=gnu
- mode as is a basic arithmetic expression using those; this is for things in
- legacy-code like:
-
- INTEGER :: arr(n), n
- INTEGER :: arr(n + 1), n
-
- The namespace is needed for IMPLICIT typing. */
-
-static gfc_namespace* check_typed_ns;
-
-static bool
-expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
- int* f ATTRIBUTE_UNUSED)
-{
- bool t;
-
- if (e->expr_type != EXPR_VARIABLE)
- return false;
-
- gcc_assert (e->symtree);
- t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
- true, e->where);
-
- return (!t);
-}
-
-bool
-gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
-{
- bool error_found;
-
- /* If this is a top-level variable or EXPR_OP, do the check with strict given
- to us. */
- if (!strict)
- {
- if (e->expr_type == EXPR_VARIABLE && !e->ref)
- return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
-
- if (e->expr_type == EXPR_OP)
- {
- bool t = true;
-
- gcc_assert (e->value.op.op1);
- t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
-
- if (t && e->value.op.op2)
- t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
-
- return t;
- }
- }
-
- /* Otherwise, walk the expression and do it strictly. */
- check_typed_ns = ns;
- error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
-
- return error_found ? false : true;
-}
-
-
-/* This function returns true if it contains any references to PDT KIND
- or LEN parameters. */
-
-static bool
-derived_parameter_expr (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
- int* f ATTRIBUTE_UNUSED)
-{
- if (e->expr_type != EXPR_VARIABLE)
- return false;
-
- gcc_assert (e->symtree);
- if (e->symtree->n.sym->attr.pdt_kind
- || e->symtree->n.sym->attr.pdt_len)
- return true;
-
- return false;
-}
-
-
-bool
-gfc_derived_parameter_expr (gfc_expr *e)
-{
- return gfc_traverse_expr (e, NULL, &derived_parameter_expr, 0);
-}
-
-
-/* This function returns the overall type of a type parameter spec list.
- If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the
- parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned
- unless derived is not NULL. In this latter case, all the LEN parameters
- must be either assumed or deferred for the return argument to be set to
- anything other than SPEC_EXPLICIT. */
-
-gfc_param_spec_type
-gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived)
-{
- gfc_param_spec_type res = SPEC_EXPLICIT;
- gfc_component *c;
- bool seen_assumed = false;
- bool seen_deferred = false;
-
- if (derived == NULL)
- {
- for (; param_list; param_list = param_list->next)
- if (param_list->spec_type == SPEC_ASSUMED
- || param_list->spec_type == SPEC_DEFERRED)
- return param_list->spec_type;
- }
- else
- {
- for (; param_list; param_list = param_list->next)
- {
- c = gfc_find_component (derived, param_list->name,
- true, true, NULL);
- gcc_assert (c != NULL);
- if (c->attr.pdt_kind)
- continue;
- else if (param_list->spec_type == SPEC_EXPLICIT)
- return SPEC_EXPLICIT;
- seen_assumed = param_list->spec_type == SPEC_ASSUMED;
- seen_deferred = param_list->spec_type == SPEC_DEFERRED;
- if (seen_assumed && seen_deferred)
- return SPEC_EXPLICIT;
- }
- res = seen_assumed ? SPEC_ASSUMED : SPEC_DEFERRED;
- }
- return res;
-}
-
-
-bool
-gfc_ref_this_image (gfc_ref *ref)
-{
- int n;
-
- gcc_assert (ref->type == REF_ARRAY && ref->u.ar.codimen > 0);
-
- for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
- if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
- return false;
-
- return true;
-}
-
-gfc_expr *
-gfc_find_team_co (gfc_expr *e)
-{
- gfc_ref *ref;
-
- for (ref = e->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
- return ref->u.ar.team;
-
- if (e->value.function.actual->expr)
- for (ref = e->value.function.actual->expr->ref; ref;
- ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
- return ref->u.ar.team;
-
- return NULL;
-}
-
-gfc_expr *
-gfc_find_stat_co (gfc_expr *e)
-{
- gfc_ref *ref;
-
- for (ref = e->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
- return ref->u.ar.stat;
-
- if (e->value.function.actual->expr)
- for (ref = e->value.function.actual->expr->ref; ref;
- ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
- return ref->u.ar.stat;
-
- return NULL;
-}
-
-bool
-gfc_is_coindexed (gfc_expr *e)
-{
- gfc_ref *ref;
-
- for (ref = e->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
- return !gfc_ref_this_image (ref);
-
- return false;
-}
-
-
-/* Coarrays are variables with a corank but not being coindexed. However, also
- the following is a coarray: A subobject of a coarray is a coarray if it does
- not have any cosubscripts, vector subscripts, allocatable component
- selection, or pointer component selection. (F2008, 2.4.7) */
-
-bool
-gfc_is_coarray (gfc_expr *e)
-{
- gfc_ref *ref;
- gfc_symbol *sym;
- gfc_component *comp;
- bool coindexed;
- bool coarray;
- int i;
-
- if (e->expr_type != EXPR_VARIABLE)
- return false;
-
- coindexed = false;
- sym = e->symtree->n.sym;
-
- if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
- coarray = CLASS_DATA (sym)->attr.codimension;
- else
- coarray = sym->attr.codimension;
-
- for (ref = e->ref; ref; ref = ref->next)
- switch (ref->type)
- {
- case REF_COMPONENT:
- comp = ref->u.c.component;
- if (comp->ts.type == BT_CLASS && comp->attr.class_ok
- && (CLASS_DATA (comp)->attr.class_pointer
- || CLASS_DATA (comp)->attr.allocatable))
- {
- coindexed = false;
- coarray = CLASS_DATA (comp)->attr.codimension;
- }
- else if (comp->attr.pointer || comp->attr.allocatable)
- {
- coindexed = false;
- coarray = comp->attr.codimension;
- }
- break;
-
- case REF_ARRAY:
- if (!coarray)
- break;
-
- if (ref->u.ar.codimen > 0 && !gfc_ref_this_image (ref))
- {
- coindexed = true;
- break;
- }
-
- for (i = 0; i < ref->u.ar.dimen; i++)
- if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
- {
- coarray = false;
- break;
- }
- break;
-
- case REF_SUBSTRING:
- case REF_INQUIRY:
- break;
- }
-
- return coarray && !coindexed;
-}
-
-
-int
-gfc_get_corank (gfc_expr *e)
-{
- int corank;
- gfc_ref *ref;
-
- if (!gfc_is_coarray (e))
- return 0;
-
- if (e->ts.type == BT_CLASS && e->ts.u.derived->components)
- corank = e->ts.u.derived->components->as
- ? e->ts.u.derived->components->as->corank : 0;
- else
- corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
-
- for (ref = e->ref; ref; ref = ref->next)
- {
- if (ref->type == REF_ARRAY)
- corank = ref->u.ar.as->corank;
- gcc_assert (ref->type != REF_SUBSTRING);
- }
-
- return corank;
-}
-
-
-/* Check whether the expression has an ultimate allocatable component.
- Being itself allocatable does not count. */
-bool
-gfc_has_ultimate_allocatable (gfc_expr *e)
-{
- gfc_ref *ref, *last = NULL;
-
- if (e->expr_type != EXPR_VARIABLE)
- return false;
-
- for (ref = e->ref; ref; ref = ref->next)
- if (ref->type == REF_COMPONENT)
- last = ref;
-
- if (last && last->u.c.component->ts.type == BT_CLASS)
- return CLASS_DATA (last->u.c.component)->attr.alloc_comp;
- else if (last && last->u.c.component->ts.type == BT_DERIVED)
- return last->u.c.component->ts.u.derived->attr.alloc_comp;
- else if (last)
- return false;
-
- if (e->ts.type == BT_CLASS)
- return CLASS_DATA (e)->attr.alloc_comp;
- else if (e->ts.type == BT_DERIVED)
- return e->ts.u.derived->attr.alloc_comp;
- else
- return false;
-}
-
-
-/* Check whether the expression has an pointer component.
- Being itself a pointer does not count. */
-bool
-gfc_has_ultimate_pointer (gfc_expr *e)
-{
- gfc_ref *ref, *last = NULL;
-
- if (e->expr_type != EXPR_VARIABLE)
- return false;
-
- for (ref = e->ref; ref; ref = ref->next)
- if (ref->type == REF_COMPONENT)
- last = ref;
-
- if (last && last->u.c.component->ts.type == BT_CLASS)
- return CLASS_DATA (last->u.c.component)->attr.pointer_comp;
- else if (last && last->u.c.component->ts.type == BT_DERIVED)
- return last->u.c.component->ts.u.derived->attr.pointer_comp;
- else if (last)
- return false;
-
- if (e->ts.type == BT_CLASS)
- return CLASS_DATA (e)->attr.pointer_comp;
- else if (e->ts.type == BT_DERIVED)
- return e->ts.u.derived->attr.pointer_comp;
- else
- return false;
-}
-
-
-/* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
- Note: A scalar is not regarded as "simply contiguous" by the standard.
- if bool is not strict, some further checks are done - for instance,
- a "(::1)" is accepted. */
-
-bool
-gfc_is_simply_contiguous (gfc_expr *expr, bool strict, bool permit_element)
-{
- bool colon;
- int i;
- gfc_array_ref *ar = NULL;
- gfc_ref *ref, *part_ref = NULL;
- gfc_symbol *sym;
-
- if (expr->expr_type == EXPR_ARRAY)
- return true;
-
- if (expr->expr_type == EXPR_FUNCTION)
- {
- if (expr->value.function.isym)
- /* TRANSPOSE is the only intrinsic that may return a
- non-contiguous array. It's treated as a special case in
- gfc_conv_expr_descriptor too. */
- return (expr->value.function.isym->id != GFC_ISYM_TRANSPOSE);
- else if (expr->value.function.esym)
- /* Only a pointer to an array without the contiguous attribute
- can be non-contiguous as a result value. */
- return (expr->value.function.esym->result->attr.contiguous
- || !expr->value.function.esym->result->attr.pointer);
- else
- {
- /* Type-bound procedures. */
- gfc_symbol *s = expr->symtree->n.sym;
- if (s->ts.type != BT_CLASS && s->ts.type != BT_DERIVED)
- return false;
-
- gfc_ref *rc = NULL;
- for (gfc_ref *r = expr->ref; r; r = r->next)
- if (r->type == REF_COMPONENT)
- rc = r;
-
- if (rc == NULL || rc->u.c.component == NULL
- || rc->u.c.component->ts.interface == NULL)
- return false;
-
- return rc->u.c.component->ts.interface->attr.contiguous;
- }
- }
- else if (expr->expr_type != EXPR_VARIABLE)
- return false;
-
- if (!permit_element && expr->rank == 0)
- return false;
-
- for (ref = expr->ref; ref; ref = ref->next)
- {
- if (ar)
- return false; /* Array shall be last part-ref. */
-
- if (ref->type == REF_COMPONENT)
- part_ref = ref;
- else if (ref->type == REF_SUBSTRING)
- return false;
- else if (ref->type == REF_INQUIRY)
- return false;
- else if (ref->u.ar.type != AR_ELEMENT)
- ar = &ref->u.ar;
- }
-
- sym = expr->symtree->n.sym;
- if (expr->ts.type != BT_CLASS
- && ((part_ref
- && !part_ref->u.c.component->attr.contiguous
- && part_ref->u.c.component->attr.pointer)
- || (!part_ref
- && !sym->attr.contiguous
- && (sym->attr.pointer
- || (sym->as && sym->as->type == AS_ASSUMED_RANK)
- || (sym->as && sym->as->type == AS_ASSUMED_SHAPE)))))
- return false;
-
- if (!ar || ar->type == AR_FULL)
- return true;
-
- gcc_assert (ar->type == AR_SECTION);
-
- /* Check for simply contiguous array */
- colon = true;
- for (i = 0; i < ar->dimen; i++)
- {
- if (ar->dimen_type[i] == DIMEN_VECTOR)
- return false;
-
- if (ar->dimen_type[i] == DIMEN_ELEMENT)
- {
- colon = false;
- continue;
- }
-
- gcc_assert (ar->dimen_type[i] == DIMEN_RANGE);
-
-
- /* If the previous section was not contiguous, that's an error,
- unless we have effective only one element and checking is not
- strict. */
- if (!colon && (strict || !ar->start[i] || !ar->end[i]
- || ar->start[i]->expr_type != EXPR_CONSTANT
- || ar->end[i]->expr_type != EXPR_CONSTANT
- || mpz_cmp (ar->start[i]->value.integer,
- ar->end[i]->value.integer) != 0))
- return false;
-
- /* Following the standard, "(::1)" or - if known at compile time -
- "(lbound:ubound)" are not simply contiguous; if strict
- is false, they are regarded as simply contiguous. */
- if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT
- || ar->stride[i]->ts.type != BT_INTEGER
- || mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0))
- return false;
-
- if (ar->start[i]
- && (strict || ar->start[i]->expr_type != EXPR_CONSTANT
- || !ar->as->lower[i]
- || ar->as->lower[i]->expr_type != EXPR_CONSTANT
- || mpz_cmp (ar->start[i]->value.integer,
- ar->as->lower[i]->value.integer) != 0))
- colon = false;
-
- if (ar->end[i]
- && (strict || ar->end[i]->expr_type != EXPR_CONSTANT
- || !ar->as->upper[i]
- || ar->as->upper[i]->expr_type != EXPR_CONSTANT
- || mpz_cmp (ar->end[i]->value.integer,
- ar->as->upper[i]->value.integer) != 0))
- colon = false;
- }
-
- return true;
-}
-
-/* Return true if the expression is guaranteed to be non-contiguous,
- false if we cannot prove anything. It is probably best to call
- this after gfc_is_simply_contiguous. If neither of them returns
- true, we cannot say (at compile-time). */
-
-bool
-gfc_is_not_contiguous (gfc_expr *array)
-{
- int i;
- gfc_array_ref *ar = NULL;
- gfc_ref *ref;
- bool previous_incomplete;
-
- for (ref = array->ref; ref; ref = ref->next)
- {
- /* Array-ref shall be last ref. */
-
- if (ar && ar->type != AR_ELEMENT)
- return true;
-
- if (ref->type == REF_ARRAY)
- ar = &ref->u.ar;
- }
-
- if (ar == NULL || ar->type != AR_SECTION)
- return false;
-
- previous_incomplete = false;
-
- /* Check if we can prove that the array is not contiguous. */
-
- for (i = 0; i < ar->dimen; i++)
- {
- mpz_t arr_size, ref_size;
-
- if (gfc_ref_dimen_size (ar, i, &ref_size, NULL))
- {
- if (gfc_dep_difference (ar->as->upper[i], ar->as->lower[i], &arr_size))
- {
- /* a(2:4,2:) is known to be non-contiguous, but
- a(2:4,i:i) can be contiguous. */
- mpz_add_ui (arr_size, arr_size, 1L);
- if (previous_incomplete && mpz_cmp_si (ref_size, 1) != 0)
- {
- mpz_clear (arr_size);
- mpz_clear (ref_size);
- return true;
- }
- else if (mpz_cmp (arr_size, ref_size) != 0)
- previous_incomplete = true;
-
- mpz_clear (arr_size);
- }
-
- /* Check for a(::2), i.e. where the stride is not unity.
- This is only done if there is more than one element in
- the reference along this dimension. */
-
- if (mpz_cmp_ui (ref_size, 1) > 0 && ar->type == AR_SECTION
- && ar->dimen_type[i] == DIMEN_RANGE
- && ar->stride[i] && ar->stride[i]->expr_type == EXPR_CONSTANT
- && mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0)
- {
- mpz_clear (ref_size);
- return true;
- }
-
- mpz_clear (ref_size);
- }
- }
- /* We didn't find anything definitive. */
- return false;
-}
-
-/* Build call to an intrinsic procedure. The number of arguments has to be
- passed (rather than ending the list with a NULL value) because we may
- want to add arguments but with a NULL-expression. */
-
-gfc_expr*
-gfc_build_intrinsic_call (gfc_namespace *ns, gfc_isym_id id, const char* name,
- locus where, unsigned numarg, ...)
-{
- gfc_expr* result;
- gfc_actual_arglist* atail;
- gfc_intrinsic_sym* isym;
- va_list ap;
- unsigned i;
- const char *mangled_name = gfc_get_string (GFC_PREFIX ("%s"), name);
-
- isym = gfc_intrinsic_function_by_id (id);
- gcc_assert (isym);
-
- result = gfc_get_expr ();
- result->expr_type = EXPR_FUNCTION;
- result->ts = isym->ts;
- result->where = where;
- result->value.function.name = mangled_name;
- result->value.function.isym = isym;
-
- gfc_get_sym_tree (mangled_name, ns, &result->symtree, false);
- gfc_commit_symbol (result->symtree->n.sym);
- gcc_assert (result->symtree
- && (result->symtree->n.sym->attr.flavor == FL_PROCEDURE
- || result->symtree->n.sym->attr.flavor == FL_UNKNOWN));
- result->symtree->n.sym->intmod_sym_id = id;
- result->symtree->n.sym->attr.flavor = FL_PROCEDURE;
- result->symtree->n.sym->attr.intrinsic = 1;
- result->symtree->n.sym->attr.artificial = 1;
-
- va_start (ap, numarg);
- atail = NULL;
- for (i = 0; i < numarg; ++i)
- {
- if (atail)
- {
- atail->next = gfc_get_actual_arglist ();
- atail = atail->next;
- }
- else
- atail = result->value.function.actual = gfc_get_actual_arglist ();
-
- atail->expr = va_arg (ap, gfc_expr*);
- }
- va_end (ap);
-
- return result;
-}
-
-
-/* Check if an expression may appear in a variable definition context
- (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
- This is called from the various places when resolving
- the pieces that make up such a context.
- If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
- variables), some checks are not performed.
-
- Optionally, a possible error message can be suppressed if context is NULL
- and just the return status (true / false) be requested. */
-
-bool
-gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
- bool own_scope, const char* context)
-{
- gfc_symbol* sym = NULL;
- bool is_pointer;
- bool check_intentin;
- bool ptr_component;
- symbol_attribute attr;
- gfc_ref* ref;
- int i;
-
- if (e->expr_type == EXPR_VARIABLE)
- {
- gcc_assert (e->symtree);
- sym = e->symtree->n.sym;
- }
- else if (e->expr_type == EXPR_FUNCTION)
- {
- gcc_assert (e->symtree);
- sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym;
- }
-
- attr = gfc_expr_attr (e);
- if (!pointer && e->expr_type == EXPR_FUNCTION && attr.pointer)
- {
- if (!(gfc_option.allow_std & GFC_STD_F2008))
- {
- if (context)
- gfc_error ("Fortran 2008: Pointer functions in variable definition"
- " context (%s) at %L", context, &e->where);
- return false;
- }
- }
- else if (e->expr_type != EXPR_VARIABLE)
- {
- if (context)
- gfc_error ("Non-variable expression in variable definition context (%s)"
- " at %L", context, &e->where);
- return false;
- }
-
- if (!pointer && sym->attr.flavor == FL_PARAMETER)
- {
- if (context)
- gfc_error ("Named constant %qs in variable definition context (%s)"
- " at %L", sym->name, context, &e->where);
- return false;
- }
- if (!pointer && sym->attr.flavor != FL_VARIABLE
- && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result)
- && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer)
- && !(sym->attr.flavor == FL_PROCEDURE
- && sym->attr.function && sym->attr.pointer))
- {
- if (context)
- gfc_error ("%qs in variable definition context (%s) at %L is not"
- " a variable", sym->name, context, &e->where);
- return false;
- }
-
- /* Find out whether the expr is a pointer; this also means following
- component references to the last one. */
- is_pointer = (attr.pointer || attr.proc_pointer);
- if (pointer && !is_pointer)
- {
- if (context)
- gfc_error ("Non-POINTER in pointer association context (%s)"
- " at %L", context, &e->where);
- return false;
- }
-
- if (e->ts.type == BT_DERIVED
- && e->ts.u.derived == NULL)
- {
- if (context)
- gfc_error ("Type inaccessible in variable definition context (%s) "
- "at %L", context, &e->where);
- return false;
- }
-
- /* F2008, C1303. */
- if (!alloc_obj
- && (attr.lock_comp
- || (e->ts.type == BT_DERIVED
- && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
- && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)))
- {
- if (context)
- gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
- context, &e->where);
- return false;
- }
-
- /* TS18508, C702/C203. */
- if (!alloc_obj
- && (attr.lock_comp
- || (e->ts.type == BT_DERIVED
- && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
- && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)))
- {
- if (context)
- gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
- context, &e->where);
- return false;
- }
-
- /* INTENT(IN) dummy argument. Check this, unless the object itself is the
- component of sub-component of a pointer; we need to distinguish
- assignment to a pointer component from pointer-assignment to a pointer
- component. Note that (normal) assignment to procedure pointers is not
- possible. */
- check_intentin = !own_scope;
- ptr_component = (sym->ts.type == BT_CLASS && sym->ts.u.derived
- && CLASS_DATA (sym))
- ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer;
- for (ref = e->ref; ref && check_intentin; ref = ref->next)
- {
- if (ptr_component && ref->type == REF_COMPONENT)
- check_intentin = false;
- if (ref->type == REF_COMPONENT)
- {
- gfc_component *comp = ref->u.c.component;
- ptr_component = (comp->ts.type == BT_CLASS && comp->attr.class_ok)
- ? CLASS_DATA (comp)->attr.class_pointer
- : comp->attr.pointer;
- if (ptr_component && !pointer)
- check_intentin = false;
- }
- if (ref->type == REF_INQUIRY
- && (ref->u.i == INQUIRY_KIND || ref->u.i == INQUIRY_LEN))
- {
- if (context)
- gfc_error ("%qs parameter inquiry for %qs in "
- "variable definition context (%s) at %L",
- ref->u.i == INQUIRY_KIND ? "KIND" : "LEN",
- sym->name, context, &e->where);
- return false;
- }
- }
-
- if (check_intentin
- && (sym->attr.intent == INTENT_IN
- || (sym->attr.select_type_temporary && sym->assoc
- && sym->assoc->target && sym->assoc->target->symtree
- && sym->assoc->target->symtree->n.sym->attr.intent == INTENT_IN)))
- {
- if (pointer && is_pointer)
- {
- if (context)
- gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
- " association context (%s) at %L",
- sym->name, context, &e->where);
- return false;
- }
- if (!pointer && !is_pointer && !sym->attr.pointer)
- {
- const char *name = sym->attr.select_type_temporary
- ? sym->assoc->target->symtree->name : sym->name;
- if (context)
- gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
- " definition context (%s) at %L",
- name, context, &e->where);
- return false;
- }
- }
-
- /* PROTECTED and use-associated. */
- if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin)
- {
- if (pointer && is_pointer)
- {
- if (context)
- gfc_error ("Variable %qs is PROTECTED and cannot appear in a"
- " pointer association context (%s) at %L",
- sym->name, context, &e->where);
- return false;
- }
- if (!pointer && !is_pointer)
- {
- if (context)
- gfc_error ("Variable %qs is PROTECTED and cannot appear in a"
- " variable definition context (%s) at %L",
- sym->name, context, &e->where);
- return false;
- }
- }
-
- /* Variable not assignable from a PURE procedure but appears in
- variable definition context. */
- own_scope = own_scope
- || (sym->attr.result && sym->ns->proc_name
- && sym == sym->ns->proc_name->result);
- if (!pointer && !own_scope && gfc_pure (NULL) && gfc_impure_variable (sym))
- {
- if (context)
- gfc_error ("Variable %qs cannot appear in a variable definition"
- " context (%s) at %L in PURE procedure",
- sym->name, context, &e->where);
- return false;
- }
-
- if (!pointer && context && gfc_implicit_pure (NULL)
- && gfc_impure_variable (sym))
- {
- gfc_namespace *ns;
- gfc_symbol *sym;
-
- for (ns = gfc_current_ns; ns; ns = ns->parent)
- {
- sym = ns->proc_name;
- if (sym == NULL)
- break;
- if (sym->attr.flavor == FL_PROCEDURE)
- {
- sym->attr.implicit_pure = 0;
- break;
- }
- }
- }
- /* Check variable definition context for associate-names. */
- if (!pointer && sym->assoc && !sym->attr.select_rank_temporary)
- {
- const char* name;
- gfc_association_list* assoc;
-
- gcc_assert (sym->assoc->target);
-
- /* If this is a SELECT TYPE temporary (the association is used internally
- for SELECT TYPE), silently go over to the target. */
- if (sym->attr.select_type_temporary)
- {
- gfc_expr* t = sym->assoc->target;
-
- gcc_assert (t->expr_type == EXPR_VARIABLE);
- name = t->symtree->name;
-
- if (t->symtree->n.sym->assoc)
- assoc = t->symtree->n.sym->assoc;
- else
- assoc = sym->assoc;
- }
- else
- {
- name = sym->name;
- assoc = sym->assoc;
- }
- gcc_assert (name && assoc);
-
- /* Is association to a valid variable? */
- if (!assoc->variable)
- {
- if (context)
- {
- if (assoc->target->expr_type == EXPR_VARIABLE)
- gfc_error ("%qs at %L associated to vector-indexed target"
- " cannot be used in a variable definition"
- " context (%s)",
- name, &e->where, context);
- else
- gfc_error ("%qs at %L associated to expression"
- " cannot be used in a variable definition"
- " context (%s)",
- name, &e->where, context);
- }
- return false;
- }
-
- /* Target must be allowed to appear in a variable definition context. */
- if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL))
- {
- if (context)
- gfc_error ("Associate-name %qs cannot appear in a variable"
- " definition context (%s) at %L because its target"
- " at %L cannot, either",
- name, context, &e->where,
- &assoc->target->where);
- return false;
- }
- }
-
- /* Check for same value in vector expression subscript. */
-
- if (e->rank > 0)
- for (ref = e->ref; ref != NULL; ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
- for (i = 0; i < GFC_MAX_DIMENSIONS
- && ref->u.ar.dimen_type[i] != 0; i++)
- if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
- {
- gfc_expr *arr = ref->u.ar.start[i];
- if (arr->expr_type == EXPR_ARRAY)
- {
- gfc_constructor *c, *n;
- gfc_expr *ec, *en;
-
- for (c = gfc_constructor_first (arr->value.constructor);
- c != NULL; c = gfc_constructor_next (c))
- {
- if (c == NULL || c->iterator != NULL)
- continue;
-
- ec = c->expr;
-
- for (n = gfc_constructor_next (c); n != NULL;
- n = gfc_constructor_next (n))
- {
- if (n->iterator != NULL)
- continue;
-
- en = n->expr;
- if (gfc_dep_compare_expr (ec, en) == 0)
- {
- if (context)
- gfc_error_now ("Elements with the same value "
- "at %L and %L in vector "
- "subscript in a variable "
- "definition context (%s)",
- &(ec->where), &(en->where),
- context);
- return false;
- }
- }
- }
- }
- }
-
- return true;
-}
generated by cgit v1.1 at 2025-04-24 20:49:52 +0000