aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/frontend-passes.cc
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/frontend-passes.cc
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/frontend-passes.cc')
-rw-r--r--gcc/fortran/frontend-passes.cc5951
1 files changed, 5951 insertions, 0 deletions
diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc
new file mode 100644
index 0000000..22f1bb5
--- /dev/null
+++ b/gcc/fortran/frontend-passes.cc
@@ -0,0 +1,5951 @@
+/* Pass manager for Fortran front end.
+ Copyright (C) 2010-2022 Free Software Foundation, Inc.
+ Contributed by Thomas König.
+
+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 "dependency.h"
+#include "constructor.h"
+#include "intrinsic.h"
+
+/* Forward declarations. */
+
+static void strip_function_call (gfc_expr *);
+static void optimize_namespace (gfc_namespace *);
+static void optimize_assignment (gfc_code *);
+static bool optimize_op (gfc_expr *);
+static bool optimize_comparison (gfc_expr *, gfc_intrinsic_op);
+static bool optimize_trim (gfc_expr *);
+static bool optimize_lexical_comparison (gfc_expr *);
+static void optimize_minmaxloc (gfc_expr **);
+static bool is_empty_string (gfc_expr *e);
+static void doloop_warn (gfc_namespace *);
+static int do_intent (gfc_expr **);
+static int do_subscript (gfc_expr **);
+static void optimize_reduction (gfc_namespace *);
+static int callback_reduction (gfc_expr **, int *, void *);
+static void realloc_strings (gfc_namespace *);
+static gfc_expr *create_var (gfc_expr *, const char *vname=NULL);
+static int matmul_to_var_expr (gfc_expr **, int *, void *);
+static int matmul_to_var_code (gfc_code **, int *, void *);
+static int inline_matmul_assign (gfc_code **, int *, void *);
+static gfc_code * create_do_loop (gfc_expr *, gfc_expr *, gfc_expr *,
+ locus *, gfc_namespace *,
+ char *vname=NULL);
+static gfc_expr* check_conjg_transpose_variable (gfc_expr *, bool *,
+ bool *);
+static int call_external_blas (gfc_code **, int *, void *);
+static int matmul_temp_args (gfc_code **, int *,void *data);
+static int index_interchange (gfc_code **, int*, void *);
+static bool is_fe_temp (gfc_expr *e);
+
+#ifdef CHECKING_P
+static void check_locus (gfc_namespace *);
+#endif
+
+/* How deep we are inside an argument list. */
+
+static int count_arglist;
+
+/* Vector of gfc_expr ** we operate on. */
+
+static vec<gfc_expr **> expr_array;
+
+/* Pointer to the gfc_code we currently work on - to be able to insert
+ a block before the statement. */
+
+static gfc_code **current_code;
+
+/* Pointer to the block to be inserted, and the statement we are
+ changing within the block. */
+
+static gfc_code *inserted_block, **changed_statement;
+
+/* The namespace we are currently dealing with. */
+
+static gfc_namespace *current_ns;
+
+/* If we are within any forall loop. */
+
+static int forall_level;
+
+/* Keep track of whether we are within an OMP workshare. */
+
+static bool in_omp_workshare;
+
+/* Keep track of whether we are within an OMP atomic. */
+
+static bool in_omp_atomic;
+
+/* Keep track of whether we are within a WHERE statement. */
+
+static bool in_where;
+
+/* Keep track of iterators for array constructors. */
+
+static int iterator_level;
+
+/* Keep track of DO loop levels. */
+
+typedef struct {
+ gfc_code *c;
+ int branch_level;
+ bool seen_goto;
+} do_t;
+
+static vec<do_t> doloop_list;
+static int doloop_level;
+
+/* Keep track of if and select case levels. */
+
+static int if_level;
+static int select_level;
+
+/* Vector of gfc_expr * to keep track of DO loops. */
+
+struct my_struct *evec;
+
+/* Keep track of association lists. */
+
+static bool in_assoc_list;
+
+/* Counter for temporary variables. */
+
+static int var_num = 1;
+
+/* What sort of matrix we are dealing with when inlining MATMUL. */
+
+enum matrix_case { none=0, A2B2, A2B1, A1B2, A2B2T, A2TB2, A2TB2T };
+
+/* Keep track of the number of expressions we have inserted so far
+ using create_var. */
+
+int n_vars;
+
+/* Entry point - run all passes for a namespace. */
+
+void
+gfc_run_passes (gfc_namespace *ns)
+{
+
+ /* Warn about dubious DO loops where the index might
+ change. */
+
+ doloop_level = 0;
+ if_level = 0;
+ select_level = 0;
+ doloop_warn (ns);
+ doloop_list.release ();
+ int w, e;
+
+#ifdef CHECKING_P
+ check_locus (ns);
+#endif
+
+ gfc_get_errors (&w, &e);
+ if (e > 0)
+ return;
+
+ if (flag_frontend_optimize || flag_frontend_loop_interchange)
+ optimize_namespace (ns);
+
+ if (flag_frontend_optimize)
+ {
+ optimize_reduction (ns);
+ if (flag_dump_fortran_optimized)
+ gfc_dump_parse_tree (ns, stdout);
+
+ expr_array.release ();
+ }
+
+ if (flag_realloc_lhs)
+ realloc_strings (ns);
+}
+
+#ifdef CHECKING_P
+
+/* Callback function: Warn if there is no location information in a
+ statement. */
+
+static int
+check_locus_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ current_code = c;
+ if (c && *c && (((*c)->loc.nextc == NULL) || ((*c)->loc.lb == NULL)))
+ gfc_warning_internal (0, "Inconsistent internal state: "
+ "No location in statement");
+
+ return 0;
+}
+
+
+/* Callback function: Warn if there is no location information in an
+ expression. */
+
+static int
+check_locus_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+
+ if (e && *e && (((*e)->where.nextc == NULL || (*e)->where.lb == NULL)))
+ gfc_warning_internal (0, "Inconsistent internal state: "
+ "No location in expression near %L",
+ &((*current_code)->loc));
+ return 0;
+}
+
+/* Run check for missing location information. */
+
+static void
+check_locus (gfc_namespace *ns)
+{
+ gfc_code_walker (&ns->code, check_locus_code, check_locus_expr, NULL);
+
+ for (ns = ns->contained; ns; ns = ns->sibling)
+ {
+ if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
+ check_locus (ns);
+ }
+}
+
+#endif
+
+/* Callback for each gfc_code node invoked from check_realloc_strings.
+ For an allocatable LHS string which also appears as a variable on
+ the RHS, replace
+
+ a = a(x:y)
+
+ with
+
+ tmp = a(x:y)
+ a = tmp
+ */
+
+static int
+realloc_string_callback (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_expr *expr1, *expr2;
+ gfc_code *co = *c;
+ gfc_expr *n;
+ gfc_ref *ref;
+ bool found_substr;
+
+ if (co->op != EXEC_ASSIGN)
+ return 0;
+
+ expr1 = co->expr1;
+ if (expr1->ts.type != BT_CHARACTER
+ || !gfc_expr_attr(expr1).allocatable
+ || !expr1->ts.deferred)
+ return 0;
+
+ if (is_fe_temp (expr1))
+ return 0;
+
+ expr2 = gfc_discard_nops (co->expr2);
+
+ if (expr2->expr_type == EXPR_VARIABLE)
+ {
+ found_substr = false;
+ for (ref = expr2->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_SUBSTRING)
+ {
+ found_substr = true;
+ break;
+ }
+ }
+ if (!found_substr)
+ return 0;
+ }
+ else if (expr2->expr_type != EXPR_ARRAY
+ && (expr2->expr_type != EXPR_OP
+ || expr2->value.op.op != INTRINSIC_CONCAT))
+ return 0;
+
+ if (!gfc_check_dependency (expr1, expr2, true))
+ return 0;
+
+ /* gfc_check_dependency doesn't always pick up identical expressions.
+ However, eliminating the above sends the compiler into an infinite
+ loop on valid expressions. Without this check, the gimplifier emits
+ an ICE for a = a, where a is deferred character length. */
+ if (!gfc_dep_compare_expr (expr1, expr2))
+ return 0;
+
+ current_code = c;
+ inserted_block = NULL;
+ changed_statement = NULL;
+ n = create_var (expr2, "realloc_string");
+ co->expr2 = n;
+ return 0;
+}
+
+/* Callback for each gfc_code node invoked through gfc_code_walker
+ from optimize_namespace. */
+
+static int
+optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+
+ gfc_exec_op op;
+
+ op = (*c)->op;
+
+ if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL
+ || op == EXEC_CALL_PPC)
+ count_arglist = 1;
+ else
+ count_arglist = 0;
+
+ current_code = c;
+ inserted_block = NULL;
+ changed_statement = NULL;
+
+ if (op == EXEC_ASSIGN)
+ optimize_assignment (*c);
+ return 0;
+}
+
+/* Callback for each gfc_expr node invoked through gfc_code_walker
+ from optimize_namespace. */
+
+static int
+optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ bool function_expr;
+
+ if ((*e)->expr_type == EXPR_FUNCTION)
+ {
+ count_arglist ++;
+ function_expr = true;
+ }
+ else
+ function_expr = false;
+
+ if (optimize_trim (*e))
+ gfc_simplify_expr (*e, 0);
+
+ if (optimize_lexical_comparison (*e))
+ gfc_simplify_expr (*e, 0);
+
+ if ((*e)->expr_type == EXPR_OP && optimize_op (*e))
+ gfc_simplify_expr (*e, 0);
+
+ if ((*e)->expr_type == EXPR_FUNCTION && (*e)->value.function.isym)
+ switch ((*e)->value.function.isym->id)
+ {
+ case GFC_ISYM_MINLOC:
+ case GFC_ISYM_MAXLOC:
+ optimize_minmaxloc (e);
+ break;
+ default:
+ break;
+ }
+
+ if (function_expr)
+ count_arglist --;
+
+ return 0;
+}
+
+/* Auxiliary function to handle the arguments to reduction intrinsics. If the
+ function is a scalar, just copy it; otherwise returns the new element, the
+ old one can be freed. */
+
+static gfc_expr *
+copy_walk_reduction_arg (gfc_constructor *c, gfc_expr *fn)
+{
+ gfc_expr *fcn, *e = c->expr;
+
+ fcn = gfc_copy_expr (e);
+ if (c->iterator)
+ {
+ gfc_constructor_base newbase;
+ gfc_expr *new_expr;
+ gfc_constructor *new_c;
+
+ newbase = NULL;
+ new_expr = gfc_get_expr ();
+ new_expr->expr_type = EXPR_ARRAY;
+ new_expr->ts = e->ts;
+ new_expr->where = e->where;
+ new_expr->rank = 1;
+ new_c = gfc_constructor_append_expr (&newbase, fcn, &(e->where));
+ new_c->iterator = c->iterator;
+ new_expr->value.constructor = newbase;
+ c->iterator = NULL;
+
+ fcn = new_expr;
+ }
+
+ if (fcn->rank != 0)
+ {
+ gfc_isym_id id = fn->value.function.isym->id;
+
+ if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
+ fcn = gfc_build_intrinsic_call (current_ns, id,
+ fn->value.function.isym->name,
+ fn->where, 3, fcn, NULL, NULL);
+ else if (id == GFC_ISYM_ANY || id == GFC_ISYM_ALL)
+ fcn = gfc_build_intrinsic_call (current_ns, id,
+ fn->value.function.isym->name,
+ fn->where, 2, fcn, NULL);
+ else
+ gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
+
+ fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
+ }
+
+ return fcn;
+}
+
+/* Callback function for optimzation of reductions to scalars. Transform ANY
+ ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
+ correspondingly. Handly only the simple cases without MASK and DIM. */
+
+static int
+callback_reduction (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_expr *fn, *arg;
+ gfc_intrinsic_op op;
+ gfc_isym_id id;
+ gfc_actual_arglist *a;
+ gfc_actual_arglist *dim;
+ gfc_constructor *c;
+ gfc_expr *res, *new_expr;
+ gfc_actual_arglist *mask;
+
+ fn = *e;
+
+ if (fn->rank != 0 || fn->expr_type != EXPR_FUNCTION
+ || fn->value.function.isym == NULL)
+ return 0;
+
+ id = fn->value.function.isym->id;
+
+ if (id != GFC_ISYM_SUM && id != GFC_ISYM_PRODUCT
+ && id != GFC_ISYM_ANY && id != GFC_ISYM_ALL)
+ return 0;
+
+ a = fn->value.function.actual;
+
+ /* Don't handle MASK or DIM. */
+
+ dim = a->next;
+
+ if (dim->expr != NULL)
+ return 0;
+
+ if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
+ {
+ mask = dim->next;
+ if ( mask->expr != NULL)
+ return 0;
+ }
+
+ arg = a->expr;
+
+ if (arg->expr_type != EXPR_ARRAY)
+ return 0;
+
+ switch (id)
+ {
+ case GFC_ISYM_SUM:
+ op = INTRINSIC_PLUS;
+ break;
+
+ case GFC_ISYM_PRODUCT:
+ op = INTRINSIC_TIMES;
+ break;
+
+ case GFC_ISYM_ANY:
+ op = INTRINSIC_OR;
+ break;
+
+ case GFC_ISYM_ALL:
+ op = INTRINSIC_AND;
+ break;
+
+ default:
+ return 0;
+ }
+
+ c = gfc_constructor_first (arg->value.constructor);
+
+ /* Don't do any simplififcation if we have
+ - no element in the constructor or
+ - only have a single element in the array which contains an
+ iterator. */
+
+ if (c == NULL)
+ return 0;
+
+ res = copy_walk_reduction_arg (c, fn);
+
+ c = gfc_constructor_next (c);
+ while (c)
+ {
+ new_expr = gfc_get_expr ();
+ new_expr->ts = fn->ts;
+ new_expr->expr_type = EXPR_OP;
+ new_expr->rank = fn->rank;
+ new_expr->where = fn->where;
+ new_expr->value.op.op = op;
+ new_expr->value.op.op1 = res;
+ new_expr->value.op.op2 = copy_walk_reduction_arg (c, fn);
+ res = new_expr;
+ c = gfc_constructor_next (c);
+ }
+
+ gfc_simplify_expr (res, 0);
+ *e = res;
+ gfc_free_expr (fn);
+
+ return 0;
+}
+
+/* Callback function for common function elimination, called from cfe_expr_0.
+ Put all eligible function expressions into expr_array. */
+
+static int
+cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+
+ if ((*e)->expr_type != EXPR_FUNCTION)
+ return 0;
+
+ /* We don't do character functions with unknown charlens. */
+ if ((*e)->ts.type == BT_CHARACTER
+ && ((*e)->ts.u.cl == NULL || (*e)->ts.u.cl->length == NULL
+ || (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT))
+ return 0;
+
+ /* We don't do function elimination within FORALL statements, it can
+ lead to wrong-code in certain circumstances. */
+
+ if (forall_level > 0)
+ return 0;
+
+ /* Function elimination inside an iterator could lead to functions which
+ depend on iterator variables being moved outside. FIXME: We should check
+ if the functions do indeed depend on the iterator variable. */
+
+ if (iterator_level > 0)
+ return 0;
+
+ /* If we don't know the shape at compile time, we create an allocatable
+ temporary variable to hold the intermediate result, but only if
+ allocation on assignment is active. */
+
+ if ((*e)->rank > 0 && (*e)->shape == NULL && !flag_realloc_lhs)
+ return 0;
+
+ /* Skip the test for pure functions if -faggressive-function-elimination
+ is specified. */
+ if ((*e)->value.function.esym)
+ {
+ /* Don't create an array temporary for elemental functions. */
+ if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0)
+ return 0;
+
+ /* Only eliminate potentially impure functions if the
+ user specifically requested it. */
+ if (!flag_aggressive_function_elimination
+ && !(*e)->value.function.esym->attr.pure
+ && !(*e)->value.function.esym->attr.implicit_pure)
+ return 0;
+ }
+
+ if ((*e)->value.function.isym)
+ {
+ /* Conversions are handled on the fly by the middle end,
+ transpose during trans-* stages and TRANSFER by the middle end. */
+ if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION
+ || (*e)->value.function.isym->id == GFC_ISYM_TRANSFER
+ || gfc_inline_intrinsic_function_p (*e))
+ return 0;
+
+ /* Don't create an array temporary for elemental functions,
+ as this would be wasteful of memory.
+ FIXME: Create a scalar temporary during scalarization. */
+ if ((*e)->value.function.isym->elemental && (*e)->rank > 0)
+ return 0;
+
+ if (!(*e)->value.function.isym->pure)
+ return 0;
+ }
+
+ expr_array.safe_push (e);
+ return 0;
+}
+
+/* Auxiliary function to check if an expression is a temporary created by
+ create var. */
+
+static bool
+is_fe_temp (gfc_expr *e)
+{
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ return e->symtree->n.sym->attr.fe_temp;
+}
+
+/* Determine the length of a string, if it can be evaluated as a constant
+ expression. Return a newly allocated gfc_expr or NULL on failure.
+ If the user specified a substring which is potentially longer than
+ the string itself, the string will be padded with spaces, which
+ is harmless. */
+
+static gfc_expr *
+constant_string_length (gfc_expr *e)
+{
+
+ gfc_expr *length;
+ gfc_ref *ref;
+ gfc_expr *res;
+ mpz_t value;
+
+ if (e->ts.u.cl)
+ {
+ length = e->ts.u.cl->length;
+ if (length && length->expr_type == EXPR_CONSTANT)
+ return gfc_copy_expr(length);
+ }
+
+ /* See if there is a substring. If it has a constant length, return
+ that and NULL otherwise. */
+ for (ref = e->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_SUBSTRING)
+ {
+ if (gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &value))
+ {
+ res = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
+ &e->where);
+
+ mpz_add_ui (res->value.integer, value, 1);
+ mpz_clear (value);
+ return res;
+ }
+ else
+ return NULL;
+ }
+ }
+
+ /* Return length of char symbol, if constant. */
+ if (e->symtree && e->symtree->n.sym->ts.u.cl
+ && e->symtree->n.sym->ts.u.cl->length
+ && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+ return gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
+
+ return NULL;
+
+}
+
+/* Insert a block at the current position unless it has already
+ been inserted; in this case use the one already there. */
+
+static gfc_namespace*
+insert_block ()
+{
+ gfc_namespace *ns;
+
+ /* If the block hasn't already been created, do so. */
+ if (inserted_block == NULL)
+ {
+ inserted_block = XCNEW (gfc_code);
+ inserted_block->op = EXEC_BLOCK;
+ inserted_block->loc = (*current_code)->loc;
+ ns = gfc_build_block_ns (current_ns);
+ inserted_block->ext.block.ns = ns;
+ inserted_block->ext.block.assoc = NULL;
+
+ ns->code = *current_code;
+
+ /* If the statement has a label, make sure it is transferred to
+ the newly created block. */
+
+ if ((*current_code)->here)
+ {
+ inserted_block->here = (*current_code)->here;
+ (*current_code)->here = NULL;
+ }
+
+ inserted_block->next = (*current_code)->next;
+ changed_statement = &(inserted_block->ext.block.ns->code);
+ (*current_code)->next = NULL;
+ /* Insert the BLOCK at the right position. */
+ *current_code = inserted_block;
+ ns->parent = current_ns;
+ }
+ else
+ ns = inserted_block->ext.block.ns;
+
+ return ns;
+}
+
+
+/* Insert a call to the intrinsic len. Use a different name for
+ the symbol tree so we don't run into trouble when the user has
+ renamed len for some reason. */
+
+static gfc_expr*
+get_len_call (gfc_expr *str)
+{
+ gfc_expr *fcn;
+ gfc_actual_arglist *actual_arglist;
+
+ fcn = gfc_get_expr ();
+ fcn->expr_type = EXPR_FUNCTION;
+ fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN);
+ actual_arglist = gfc_get_actual_arglist ();
+ actual_arglist->expr = str;
+
+ fcn->value.function.actual = actual_arglist;
+ fcn->where = str->where;
+ fcn->ts.type = BT_INTEGER;
+ fcn->ts.kind = gfc_charlen_int_kind;
+
+ gfc_get_sym_tree ("__internal_len", current_ns, &fcn->symtree, false);
+ fcn->symtree->n.sym->ts = fcn->ts;
+ fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+ fcn->symtree->n.sym->attr.function = 1;
+ fcn->symtree->n.sym->attr.elemental = 1;
+ fcn->symtree->n.sym->attr.referenced = 1;
+ fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
+ gfc_commit_symbol (fcn->symtree->n.sym);
+
+ return fcn;
+}
+
+
+/* Returns a new expression (a variable) to be used in place of the old one,
+ with an optional assignment statement before the current statement to set
+ the value of the variable. Creates a new BLOCK for the statement if that
+ hasn't already been done and puts the statement, plus the newly created
+ variables, in that block. Special cases: If the expression is constant or
+ a temporary which has already been created, just copy it. */
+
+static gfc_expr*
+create_var (gfc_expr * e, const char *vname)
+{
+ char name[GFC_MAX_SYMBOL_LEN +1];
+ gfc_symtree *symtree;
+ gfc_symbol *symbol;
+ gfc_expr *result;
+ gfc_code *n;
+ gfc_namespace *ns;
+ int i;
+ bool deferred;
+
+ if (e->expr_type == EXPR_CONSTANT || is_fe_temp (e))
+ return gfc_copy_expr (e);
+
+ /* Creation of an array of unknown size requires realloc on assignment.
+ If that is not possible, just return NULL. */
+ if (flag_realloc_lhs == 0 && e->rank > 0 && e->shape == NULL)
+ return NULL;
+
+ ns = insert_block ();
+
+ if (vname)
+ snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d_%s", var_num++, vname);
+ else
+ snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d", var_num++);
+
+ if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
+ gcc_unreachable ();
+
+ symbol = symtree->n.sym;
+ symbol->ts = e->ts;
+
+ if (e->rank > 0)
+ {
+ symbol->as = gfc_get_array_spec ();
+ symbol->as->rank = e->rank;
+
+ if (e->shape == NULL)
+ {
+ /* We don't know the shape at compile time, so we use an
+ allocatable. */
+ symbol->as->type = AS_DEFERRED;
+ symbol->attr.allocatable = 1;
+ }
+ else
+ {
+ symbol->as->type = AS_EXPLICIT;
+ /* Copy the shape. */
+ for (i=0; i<e->rank; i++)
+ {
+ gfc_expr *p, *q;
+
+ p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &(e->where));
+ mpz_set_si (p->value.integer, 1);
+ symbol->as->lower[i] = p;
+
+ q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
+ &(e->where));
+ mpz_set (q->value.integer, e->shape[i]);
+ symbol->as->upper[i] = q;
+ }
+ }
+ }
+
+ deferred = 0;
+ if (e->ts.type == BT_CHARACTER)
+ {
+ gfc_expr *length;
+
+ symbol->ts.u.cl = gfc_new_charlen (ns, NULL);
+ length = constant_string_length (e);
+ if (length)
+ symbol->ts.u.cl->length = length;
+ else if (e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->ts.type == BT_CHARACTER
+ && e->ts.u.cl->length)
+ symbol->ts.u.cl->length = get_len_call (gfc_copy_expr (e));
+ else
+ {
+ symbol->attr.allocatable = 1;
+ symbol->ts.u.cl->length = NULL;
+ symbol->ts.deferred = 1;
+ deferred = 1;
+ }
+ }
+
+ symbol->attr.flavor = FL_VARIABLE;
+ symbol->attr.referenced = 1;
+ symbol->attr.dimension = e->rank > 0;
+ symbol->attr.fe_temp = 1;
+ gfc_commit_symbol (symbol);
+
+ result = gfc_get_expr ();
+ result->expr_type = EXPR_VARIABLE;
+ result->ts = symbol->ts;
+ result->ts.deferred = deferred;
+ result->rank = e->rank;
+ result->shape = gfc_copy_shape (e->shape, e->rank);
+ result->symtree = symtree;
+ result->where = e->where;
+ if (e->rank > 0)
+ {
+ result->ref = gfc_get_ref ();
+ result->ref->type = REF_ARRAY;
+ result->ref->u.ar.type = AR_FULL;
+ result->ref->u.ar.where = e->where;
+ result->ref->u.ar.dimen = e->rank;
+ result->ref->u.ar.as = symbol->ts.type == BT_CLASS
+ ? CLASS_DATA (symbol)->as : symbol->as;
+ if (warn_array_temporaries)
+ gfc_warning (OPT_Warray_temporaries,
+ "Creating array temporary at %L", &(e->where));
+ }
+
+ /* Generate the new assignment. */
+ n = XCNEW (gfc_code);
+ n->op = EXEC_ASSIGN;
+ n->loc = (*current_code)->loc;
+ n->next = *changed_statement;
+ n->expr1 = gfc_copy_expr (result);
+ n->expr2 = e;
+ *changed_statement = n;
+ n_vars ++;
+
+ return result;
+}
+
+/* Warn about function elimination. */
+
+static void
+do_warn_function_elimination (gfc_expr *e)
+{
+ const char *name;
+ if (e->expr_type == EXPR_FUNCTION
+ && !gfc_pure_function (e, &name) && !gfc_implicit_pure_function (e))
+ {
+ if (name)
+ gfc_warning (OPT_Wfunction_elimination,
+ "Removing call to impure function %qs at %L", name,
+ &(e->where));
+ else
+ gfc_warning (OPT_Wfunction_elimination,
+ "Removing call to impure function at %L",
+ &(e->where));
+ }
+}
+
+
+/* Callback function for the code walker for doing common function
+ elimination. This builds up the list of functions in the expression
+ and goes through them to detect duplicates, which it then replaces
+ by variables. */
+
+static int
+cfe_expr_0 (gfc_expr **e, int *walk_subtrees,
+ void *data ATTRIBUTE_UNUSED)
+{
+ int i,j;
+ gfc_expr *newvar;
+ gfc_expr **ei, **ej;
+
+ /* Don't do this optimization within OMP workshare/atomic or ASSOC lists. */
+
+ if (in_omp_workshare || in_omp_atomic || in_assoc_list)
+ {
+ *walk_subtrees = 0;
+ return 0;
+ }
+
+ expr_array.release ();
+
+ gfc_expr_walker (e, cfe_register_funcs, NULL);
+
+ /* Walk through all the functions. */
+
+ FOR_EACH_VEC_ELT_FROM (expr_array, i, ei, 1)
+ {
+ /* Skip if the function has been replaced by a variable already. */
+ if ((*ei)->expr_type == EXPR_VARIABLE)
+ continue;
+
+ newvar = NULL;
+ for (j=0; j<i; j++)
+ {
+ ej = expr_array[j];
+ if (gfc_dep_compare_functions (*ei, *ej, true) == 0)
+ {
+ if (newvar == NULL)
+ newvar = create_var (*ei, "fcn");
+
+ if (warn_function_elimination)
+ do_warn_function_elimination (*ej);
+
+ free (*ej);
+ *ej = gfc_copy_expr (newvar);
+ }
+ }
+ if (newvar)
+ *ei = newvar;
+ }
+
+ /* We did all the necessary walking in this function. */
+ *walk_subtrees = 0;
+ return 0;
+}
+
+/* Callback function for common function elimination, called from
+ gfc_code_walker. This keeps track of the current code, in order
+ to insert statements as needed. */
+
+static int
+cfe_code (gfc_code **c, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
+{
+ current_code = c;
+ inserted_block = NULL;
+ changed_statement = NULL;
+
+ /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
+ and allocation on assigment are prohibited inside WHERE, and finally
+ masking an expression would lead to wrong-code when replacing
+
+ WHERE (a>0)
+ b = sum(foo(a) + foo(a))
+ END WHERE
+
+ with
+
+ WHERE (a > 0)
+ tmp = foo(a)
+ b = sum(tmp + tmp)
+ END WHERE
+*/
+
+ if ((*c)->op == EXEC_WHERE)
+ {
+ *walk_subtrees = 0;
+ return 0;
+ }
+
+
+ return 0;
+}
+
+/* Dummy function for expression call back, for use when we
+ really don't want to do any walking. */
+
+static int
+dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees,
+ void *data ATTRIBUTE_UNUSED)
+{
+ *walk_subtrees = 0;
+ return 0;
+}
+
+/* Dummy function for code callback, for use when we really
+ don't want to do anything. */
+int
+gfc_dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED,
+ int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ return 0;
+}
+
+/* Code callback function for converting
+ do while(a)
+ end do
+ into the equivalent
+ do
+ if (.not. a) exit
+ end do
+ This is because common function elimination would otherwise place the
+ temporary variables outside the loop. */
+
+static int
+convert_do_while (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_code *co = *c;
+ gfc_code *c_if1, *c_if2, *c_exit;
+ gfc_code *loopblock;
+ gfc_expr *e_not, *e_cond;
+
+ if (co->op != EXEC_DO_WHILE)
+ return 0;
+
+ if (co->expr1 == NULL || co->expr1->expr_type == EXPR_CONSTANT)
+ return 0;
+
+ e_cond = co->expr1;
+
+ /* Generate the condition of the if statement, which is .not. the original
+ statement. */
+ e_not = gfc_get_expr ();
+ e_not->ts = e_cond->ts;
+ e_not->where = e_cond->where;
+ e_not->expr_type = EXPR_OP;
+ e_not->value.op.op = INTRINSIC_NOT;
+ e_not->value.op.op1 = e_cond;
+
+ /* Generate the EXIT statement. */
+ c_exit = XCNEW (gfc_code);
+ c_exit->op = EXEC_EXIT;
+ c_exit->ext.which_construct = co;
+ c_exit->loc = co->loc;
+
+ /* Generate the IF statement. */
+ c_if2 = XCNEW (gfc_code);
+ c_if2->op = EXEC_IF;
+ c_if2->expr1 = e_not;
+ c_if2->next = c_exit;
+ c_if2->loc = co->loc;
+
+ /* ... plus the one to chain it to. */
+ c_if1 = XCNEW (gfc_code);
+ c_if1->op = EXEC_IF;
+ c_if1->block = c_if2;
+ c_if1->loc = co->loc;
+
+ /* Make the DO WHILE loop into a DO block by replacing the condition
+ with a true constant. */
+ co->expr1 = gfc_get_logical_expr (gfc_default_integer_kind, &co->loc, true);
+
+ /* Hang the generated if statement into the loop body. */
+
+ loopblock = co->block->next;
+ co->block->next = c_if1;
+ c_if1->next = loopblock;
+
+ return 0;
+}
+
+/* Code callback function for converting
+ if (a) then
+ ...
+ else if (b) then
+ end if
+
+ into
+ if (a) then
+ else
+ if (b) then
+ end if
+ end if
+
+ because otherwise common function elimination would place the BLOCKs
+ into the wrong place. */
+
+static int
+convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_code *co = *c;
+ gfc_code *c_if1, *c_if2, *else_stmt;
+
+ if (co->op != EXEC_IF)
+ return 0;
+
+ /* This loop starts out with the first ELSE statement. */
+ else_stmt = co->block->block;
+
+ while (else_stmt != NULL)
+ {
+ gfc_code *next_else;
+
+ /* If there is no condition, we're done. */
+ if (else_stmt->expr1 == NULL)
+ break;
+
+ next_else = else_stmt->block;
+
+ /* Generate the new IF statement. */
+ c_if2 = XCNEW (gfc_code);
+ c_if2->op = EXEC_IF;
+ c_if2->expr1 = else_stmt->expr1;
+ c_if2->next = else_stmt->next;
+ c_if2->loc = else_stmt->loc;
+ c_if2->block = next_else;
+
+ /* ... plus the one to chain it to. */
+ c_if1 = XCNEW (gfc_code);
+ c_if1->op = EXEC_IF;
+ c_if1->block = c_if2;
+ c_if1->loc = else_stmt->loc;
+
+ /* Insert the new IF after the ELSE. */
+ else_stmt->expr1 = NULL;
+ else_stmt->next = c_if1;
+ else_stmt->block = NULL;
+
+ else_stmt = next_else;
+ }
+ /* Don't walk subtrees. */
+ return 0;
+}
+
+/* Callback function to var_in_expr - return true if expr1 and
+ expr2 are identical variables. */
+static int
+var_in_expr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data)
+{
+ gfc_expr *expr1 = (gfc_expr *) data;
+ gfc_expr *expr2 = *e;
+
+ if (expr2->expr_type != EXPR_VARIABLE)
+ return 0;
+
+ return expr1->symtree->n.sym == expr2->symtree->n.sym;
+}
+
+/* Return true if expr1 is found in expr2. */
+
+static bool
+var_in_expr (gfc_expr *expr1, gfc_expr *expr2)
+{
+ gcc_assert (expr1->expr_type == EXPR_VARIABLE);
+
+ return gfc_expr_walker (&expr2, var_in_expr_callback, (void *) expr1);
+}
+
+struct do_stack
+{
+ struct do_stack *prev;
+ gfc_iterator *iter;
+ gfc_code *code;
+} *stack_top;
+
+/* Recursively traverse the block of a WRITE or READ statement, and maybe
+ optimize by replacing do loops with their analog array slices. For
+ example:
+
+ write (*,*) (a(i), i=1,4)
+
+ is replaced with
+
+ write (*,*) a(1:4:1) . */
+
+static bool
+traverse_io_block (gfc_code *code, bool *has_reached, gfc_code *prev)
+{
+ gfc_code *curr;
+ gfc_expr *new_e, *expr, *start;
+ gfc_ref *ref;
+ struct do_stack ds_push;
+ int i, future_rank = 0;
+ gfc_iterator *iters[GFC_MAX_DIMENSIONS];
+ gfc_expr *e;
+
+ /* Find the first transfer/do statement. */
+ for (curr = code; curr; curr = curr->next)
+ {
+ if (curr->op == EXEC_DO || curr->op == EXEC_TRANSFER)
+ break;
+ }
+
+ /* Ensure it is the only transfer/do statement because cases like
+
+ write (*,*) (a(i), b(i), i=1,4)
+
+ cannot be optimized. */
+
+ if (!curr || curr->next)
+ return false;
+
+ if (curr->op == EXEC_DO)
+ {
+ if (curr->ext.iterator->var->ref)
+ return false;
+ ds_push.prev = stack_top;
+ ds_push.iter = curr->ext.iterator;
+ ds_push.code = curr;
+ stack_top = &ds_push;
+ if (traverse_io_block (curr->block->next, has_reached, prev))
+ {
+ if (curr != stack_top->code && !*has_reached)
+ {
+ curr->block->next = NULL;
+ gfc_free_statements (curr);
+ }
+ else
+ *has_reached = true;
+ return true;
+ }
+ return false;
+ }
+
+ gcc_assert (curr->op == EXEC_TRANSFER);
+
+ e = curr->expr1;
+ ref = e->ref;
+ if (!ref || ref->type != REF_ARRAY || ref->u.ar.codimen != 0 || ref->next)
+ return false;
+
+ /* Find the iterators belonging to each variable and check conditions. */
+ for (i = 0; i < ref->u.ar.dimen; i++)
+ {
+ if (!ref->u.ar.start[i] || ref->u.ar.start[i]->ref
+ || ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
+ return false;
+
+ start = ref->u.ar.start[i];
+ gfc_simplify_expr (start, 0);
+ switch (start->expr_type)
+ {
+ case EXPR_VARIABLE:
+
+ /* write (*,*) (a(i), i=a%b,1) not handled yet. */
+ if (start->ref)
+ return false;
+
+ /* Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4). */
+ if (!stack_top || !stack_top->iter
+ || stack_top->iter->var->symtree != start->symtree)
+ {
+ /* Check for (a(i,i), i=1,3). */
+ int j;
+
+ for (j=0; j<i; j++)
+ if (iters[j] && iters[j]->var->symtree == start->symtree)
+ return false;
+
+ iters[i] = NULL;
+ }
+ else
+ {
+ iters[i] = stack_top->iter;
+ stack_top = stack_top->prev;
+ future_rank++;
+ }
+ break;
+ case EXPR_CONSTANT:
+ iters[i] = NULL;
+ break;
+ case EXPR_OP:
+ switch (start->value.op.op)
+ {
+ case INTRINSIC_PLUS:
+ case INTRINSIC_TIMES:
+ if (start->value.op.op1->expr_type != EXPR_VARIABLE)
+ std::swap (start->value.op.op1, start->value.op.op2);
+ gcc_fallthrough ();
+ case INTRINSIC_MINUS:
+ if (start->value.op.op1->expr_type!= EXPR_VARIABLE
+ || start->value.op.op2->expr_type != EXPR_CONSTANT
+ || start->value.op.op1->ref)
+ return false;
+ if (!stack_top || !stack_top->iter
+ || stack_top->iter->var->symtree
+ != start->value.op.op1->symtree)
+ return false;
+ iters[i] = stack_top->iter;
+ stack_top = stack_top->prev;
+ break;
+ default:
+ return false;
+ }
+ future_rank++;
+ break;
+ default:
+ return false;
+ }
+ }
+
+ /* Check for cases like ((a(i, j), i=1, j), j=1, 2). */
+ for (int i = 1; i < ref->u.ar.dimen; i++)
+ {
+ if (iters[i])
+ {
+ gfc_expr *var = iters[i]->var;
+ for (int j = i - 1; j < i; j++)
+ {
+ if (iters[j]
+ && (var_in_expr (var, iters[j]->start)
+ || var_in_expr (var, iters[j]->end)
+ || var_in_expr (var, iters[j]->step)))
+ return false;
+ }
+ }
+ }
+
+ /* Create new expr. */
+ new_e = gfc_copy_expr (curr->expr1);
+ new_e->expr_type = EXPR_VARIABLE;
+ new_e->rank = future_rank;
+ if (curr->expr1->shape)
+ new_e->shape = gfc_get_shape (new_e->rank);
+
+ /* Assign new starts, ends and strides if necessary. */
+ for (i = 0; i < ref->u.ar.dimen; i++)
+ {
+ if (!iters[i])
+ continue;
+ start = ref->u.ar.start[i];
+ switch (start->expr_type)
+ {
+ case EXPR_CONSTANT:
+ gfc_internal_error ("bad expression");
+ break;
+ case EXPR_VARIABLE:
+ new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE;
+ new_e->ref->u.ar.type = AR_SECTION;
+ gfc_free_expr (new_e->ref->u.ar.start[i]);
+ new_e->ref->u.ar.start[i] = gfc_copy_expr (iters[i]->start);
+ new_e->ref->u.ar.end[i] = gfc_copy_expr (iters[i]->end);
+ new_e->ref->u.ar.stride[i] = gfc_copy_expr (iters[i]->step);
+ break;
+ case EXPR_OP:
+ new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE;
+ new_e->ref->u.ar.type = AR_SECTION;
+ gfc_free_expr (new_e->ref->u.ar.start[i]);
+ expr = gfc_copy_expr (start);
+ expr->value.op.op1 = gfc_copy_expr (iters[i]->start);
+ new_e->ref->u.ar.start[i] = expr;
+ gfc_simplify_expr (new_e->ref->u.ar.start[i], 0);
+ expr = gfc_copy_expr (start);
+ expr->value.op.op1 = gfc_copy_expr (iters[i]->end);
+ new_e->ref->u.ar.end[i] = expr;
+ gfc_simplify_expr (new_e->ref->u.ar.end[i], 0);
+ switch (start->value.op.op)
+ {
+ case INTRINSIC_MINUS:
+ case INTRINSIC_PLUS:
+ new_e->ref->u.ar.stride[i] = gfc_copy_expr (iters[i]->step);
+ break;
+ case INTRINSIC_TIMES:
+ expr = gfc_copy_expr (start);
+ expr->value.op.op1 = gfc_copy_expr (iters[i]->step);
+ new_e->ref->u.ar.stride[i] = expr;
+ gfc_simplify_expr (new_e->ref->u.ar.stride[i], 0);
+ break;
+ default:
+ gfc_internal_error ("bad op");
+ }
+ break;
+ default:
+ gfc_internal_error ("bad expression");
+ }
+ }
+ curr->expr1 = new_e;
+
+ /* Insert modified statement. Check whether the statement needs to be
+ inserted at the lowest level. */
+ if (!stack_top->iter)
+ {
+ if (prev)
+ {
+ curr->next = prev->next->next;
+ prev->next = curr;
+ }
+ else
+ {
+ curr->next = stack_top->code->block->next->next->next;
+ stack_top->code->block->next = curr;
+ }
+ }
+ else
+ stack_top->code->block->next = curr;
+ return true;
+}
+
+/* Function for the gfc_code_walker. If code is a READ or WRITE statement, it
+ tries to optimize its block. */
+
+static int
+simplify_io_impl_do (gfc_code **code, int *walk_subtrees,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_code **curr, *prev = NULL;
+ struct do_stack write, first;
+ bool b = false;
+ *walk_subtrees = 1;
+ if (!(*code)->block
+ || ((*code)->block->op != EXEC_WRITE
+ && (*code)->block->op != EXEC_READ))
+ return 0;
+
+ *walk_subtrees = 0;
+ write.prev = NULL;
+ write.iter = NULL;
+ write.code = *code;
+
+ for (curr = &(*code)->block; *curr; curr = &(*curr)->next)
+ {
+ if ((*curr)->op == EXEC_DO)
+ {
+ first.prev = &write;
+ first.iter = (*curr)->ext.iterator;
+ first.code = *curr;
+ stack_top = &first;
+ traverse_io_block ((*curr)->block->next, &b, prev);
+ stack_top = NULL;
+ }
+ prev = *curr;
+ }
+ return 0;
+}
+
+/* Optimize a namespace, including all contained namespaces.
+ flag_frontend_optimize and flag_fronend_loop_interchange are
+ handled separately. */
+
+static void
+optimize_namespace (gfc_namespace *ns)
+{
+ gfc_namespace *saved_ns = gfc_current_ns;
+ current_ns = ns;
+ gfc_current_ns = ns;
+ forall_level = 0;
+ iterator_level = 0;
+ in_assoc_list = false;
+ in_omp_workshare = false;
+ in_omp_atomic = false;
+
+ if (flag_frontend_optimize)
+ {
+ gfc_code_walker (&ns->code, simplify_io_impl_do, dummy_expr_callback, NULL);
+ gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL);
+ gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL);
+ gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL);
+ gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
+ if (flag_inline_matmul_limit != 0 || flag_external_blas)
+ {
+ bool found;
+ do
+ {
+ found = false;
+ gfc_code_walker (&ns->code, matmul_to_var_code, matmul_to_var_expr,
+ (void *) &found);
+ }
+ while (found);
+
+ gfc_code_walker (&ns->code, matmul_temp_args, dummy_expr_callback,
+ NULL);
+ }
+
+ if (flag_external_blas)
+ gfc_code_walker (&ns->code, call_external_blas, dummy_expr_callback,
+ NULL);
+
+ if (flag_inline_matmul_limit != 0)
+ gfc_code_walker (&ns->code, inline_matmul_assign, dummy_expr_callback,
+ NULL);
+ }
+
+ if (flag_frontend_loop_interchange)
+ gfc_code_walker (&ns->code, index_interchange, dummy_expr_callback,
+ NULL);
+
+ /* BLOCKs are handled in the expression walker below. */
+ for (ns = ns->contained; ns; ns = ns->sibling)
+ {
+ if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
+ optimize_namespace (ns);
+ }
+ gfc_current_ns = saved_ns;
+}
+
+/* Handle dependencies for allocatable strings which potentially redefine
+ themselves in an assignment. */
+
+static void
+realloc_strings (gfc_namespace *ns)
+{
+ current_ns = ns;
+ gfc_code_walker (&ns->code, realloc_string_callback, dummy_expr_callback, NULL);
+
+ for (ns = ns->contained; ns; ns = ns->sibling)
+ {
+ if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
+ realloc_strings (ns);
+ }
+
+}
+
+static void
+optimize_reduction (gfc_namespace *ns)
+{
+ current_ns = ns;
+ gfc_code_walker (&ns->code, gfc_dummy_code_callback,
+ callback_reduction, NULL);
+
+/* BLOCKs are handled in the expression walker below. */
+ for (ns = ns->contained; ns; ns = ns->sibling)
+ {
+ if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
+ optimize_reduction (ns);
+ }
+}
+
+/* Replace code like
+ a = matmul(b,c) + d
+ with
+ a = matmul(b,c) ; a = a + d
+ where the array function is not elemental and not allocatable
+ and does not depend on the left-hand side.
+*/
+
+static bool
+optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
+{
+ gfc_expr *e;
+
+ if (!*rhs)
+ return false;
+
+ e = *rhs;
+ if (e->expr_type == EXPR_OP)
+ {
+ switch (e->value.op.op)
+ {
+ /* Unary operators and exponentiation: Only look at a single
+ operand. */
+ case INTRINSIC_NOT:
+ case INTRINSIC_UPLUS:
+ case INTRINSIC_UMINUS:
+ case INTRINSIC_PARENTHESES:
+ case INTRINSIC_POWER:
+ if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op))
+ return true;
+ break;
+
+ case INTRINSIC_CONCAT:
+ /* Do not do string concatenations. */
+ break;
+
+ default:
+ /* Binary operators. */
+ if (optimize_binop_array_assignment (c, &e->value.op.op1, true))
+ return true;
+
+ if (optimize_binop_array_assignment (c, &e->value.op.op2, true))
+ return true;
+
+ break;
+ }
+ }
+ else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0
+ && ! (e->value.function.esym
+ && (e->value.function.esym->attr.elemental
+ || e->value.function.esym->attr.allocatable
+ || e->value.function.esym->ts.type != c->expr1->ts.type
+ || e->value.function.esym->ts.kind != c->expr1->ts.kind))
+ && ! (e->value.function.isym
+ && (e->value.function.isym->elemental
+ || e->ts.type != c->expr1->ts.type
+ || e->ts.kind != c->expr1->ts.kind))
+ && ! gfc_inline_intrinsic_function_p (e))
+ {
+
+ gfc_code *n;
+ gfc_expr *new_expr;
+
+ /* Insert a new assignment statement after the current one. */
+ n = XCNEW (gfc_code);
+ n->op = EXEC_ASSIGN;
+ n->loc = c->loc;
+ n->next = c->next;
+ c->next = n;
+
+ n->expr1 = gfc_copy_expr (c->expr1);
+ n->expr2 = c->expr2;
+ new_expr = gfc_copy_expr (c->expr1);
+ c->expr2 = e;
+ *rhs = new_expr;
+
+ return true;
+
+ }
+
+ /* Nothing to optimize. */
+ return false;
+}
+
+/* Remove unneeded TRIMs at the end of expressions. */
+
+static bool
+remove_trim (gfc_expr *rhs)
+{
+ bool ret;
+
+ ret = false;
+ if (!rhs)
+ return ret;
+
+ /* Check for a // b // trim(c). Looping is probably not
+ necessary because the parser usually generates
+ (// (// a b ) trim(c) ) , but better safe than sorry. */
+
+ while (rhs->expr_type == EXPR_OP
+ && rhs->value.op.op == INTRINSIC_CONCAT)
+ rhs = rhs->value.op.op2;
+
+ while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym
+ && rhs->value.function.isym->id == GFC_ISYM_TRIM)
+ {
+ strip_function_call (rhs);
+ /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
+ remove_trim (rhs);
+ ret = true;
+ }
+
+ return ret;
+}
+
+/* Optimizations for an assignment. */
+
+static void
+optimize_assignment (gfc_code * c)
+{
+ gfc_expr *lhs, *rhs;
+
+ lhs = c->expr1;
+ rhs = c->expr2;
+
+ if (lhs->ts.type == BT_CHARACTER && !lhs->ts.deferred)
+ {
+ /* Optimize a = trim(b) to a = b. */
+ remove_trim (rhs);
+
+ /* Replace a = ' ' by a = '' to optimize away a memcpy. */
+ if (is_empty_string (rhs))
+ rhs->value.character.length = 0;
+ }
+
+ if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
+ optimize_binop_array_assignment (c, &rhs, false);
+}
+
+
+/* Remove an unneeded function call, modifying the expression.
+ This replaces the function call with the value of its
+ first argument. The rest of the argument list is freed. */
+
+static void
+strip_function_call (gfc_expr *e)
+{
+ gfc_expr *e1;
+ gfc_actual_arglist *a;
+
+ a = e->value.function.actual;
+
+ /* We should have at least one argument. */
+ gcc_assert (a->expr != NULL);
+
+ e1 = a->expr;
+
+ /* Free the remaining arglist, if any. */
+ if (a->next)
+ gfc_free_actual_arglist (a->next);
+
+ /* Graft the argument expression onto the original function. */
+ *e = *e1;
+ free (e1);
+
+}
+
+/* Optimization of lexical comparison functions. */
+
+static bool
+optimize_lexical_comparison (gfc_expr *e)
+{
+ if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL)
+ return false;
+
+ switch (e->value.function.isym->id)
+ {
+ case GFC_ISYM_LLE:
+ return optimize_comparison (e, INTRINSIC_LE);
+
+ case GFC_ISYM_LGE:
+ return optimize_comparison (e, INTRINSIC_GE);
+
+ case GFC_ISYM_LGT:
+ return optimize_comparison (e, INTRINSIC_GT);
+
+ case GFC_ISYM_LLT:
+ return optimize_comparison (e, INTRINSIC_LT);
+
+ default:
+ break;
+ }
+ return false;
+}
+
+/* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
+ do CHARACTER because of possible pessimization involving character
+ lengths. */
+
+static bool
+combine_array_constructor (gfc_expr *e)
+{
+
+ gfc_expr *op1, *op2;
+ gfc_expr *scalar;
+ gfc_expr *new_expr;
+ gfc_constructor *c, *new_c;
+ gfc_constructor_base oldbase, newbase;
+ bool scalar_first;
+ int n_elem;
+ bool all_const;
+
+ /* Array constructors have rank one. */
+ if (e->rank != 1)
+ return false;
+
+ /* Don't try to combine association lists, this makes no sense
+ and leads to an ICE. */
+ if (in_assoc_list)
+ return false;
+
+ /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
+ if (forall_level > 0)
+ return false;
+
+ /* Inside an iterator, things can get hairy; we are likely to create
+ an invalid temporary variable. */
+ if (iterator_level > 0)
+ return false;
+
+ /* WHERE also doesn't work. */
+ if (in_where > 0)
+ return false;
+
+ op1 = e->value.op.op1;
+ op2 = e->value.op.op2;
+
+ if (!op1 || !op2)
+ return false;
+
+ if (op1->expr_type == EXPR_ARRAY && op2->rank == 0)
+ scalar_first = false;
+ else if (op2->expr_type == EXPR_ARRAY && op1->rank == 0)
+ {
+ scalar_first = true;
+ op1 = e->value.op.op2;
+ op2 = e->value.op.op1;
+ }
+ else
+ return false;
+
+ if (op2->ts.type == BT_CHARACTER)
+ return false;
+
+ /* This might be an expanded constructor with very many constant values. If
+ we perform the operation here, we might end up with a long compile time
+ and actually longer execution time, so a length bound is in order here.
+ If the constructor constains something which is not a constant, it did
+ not come from an expansion, so leave it alone. */
+
+#define CONSTR_LEN_MAX 4
+
+ oldbase = op1->value.constructor;
+
+ n_elem = 0;
+ all_const = true;
+ for (c = gfc_constructor_first (oldbase); c; c = gfc_constructor_next(c))
+ {
+ if (c->expr->expr_type != EXPR_CONSTANT)
+ {
+ all_const = false;
+ break;
+ }
+ n_elem += 1;
+ }
+
+ if (all_const && n_elem > CONSTR_LEN_MAX)
+ return false;
+
+#undef CONSTR_LEN_MAX
+
+ newbase = NULL;
+ e->expr_type = EXPR_ARRAY;
+
+ scalar = create_var (gfc_copy_expr (op2), "constr");
+
+ for (c = gfc_constructor_first (oldbase); c;
+ c = gfc_constructor_next (c))
+ {
+ new_expr = gfc_get_expr ();
+ new_expr->ts = e->ts;
+ new_expr->expr_type = EXPR_OP;
+ new_expr->rank = c->expr->rank;
+ new_expr->where = c->expr->where;
+ new_expr->value.op.op = e->value.op.op;
+
+ if (scalar_first)
+ {
+ new_expr->value.op.op1 = gfc_copy_expr (scalar);
+ new_expr->value.op.op2 = gfc_copy_expr (c->expr);
+ }
+ else
+ {
+ new_expr->value.op.op1 = gfc_copy_expr (c->expr);
+ new_expr->value.op.op2 = gfc_copy_expr (scalar);
+ }
+
+ new_c = gfc_constructor_append_expr (&newbase, new_expr, &(e->where));
+ new_c->iterator = c->iterator;
+ c->iterator = NULL;
+ }
+
+ gfc_free_expr (op1);
+ gfc_free_expr (op2);
+ gfc_free_expr (scalar);
+
+ e->value.constructor = newbase;
+ return true;
+}
+
+/* Recursive optimization of operators. */
+
+static bool
+optimize_op (gfc_expr *e)
+{
+ bool changed;
+
+ gfc_intrinsic_op op = e->value.op.op;
+
+ changed = false;
+
+ /* Only use new-style comparisons. */
+ switch(op)
+ {
+ case INTRINSIC_EQ_OS:
+ op = INTRINSIC_EQ;
+ break;
+
+ case INTRINSIC_GE_OS:
+ op = INTRINSIC_GE;
+ break;
+
+ case INTRINSIC_LE_OS:
+ op = INTRINSIC_LE;
+ break;
+
+ case INTRINSIC_NE_OS:
+ op = INTRINSIC_NE;
+ break;
+
+ case INTRINSIC_GT_OS:
+ op = INTRINSIC_GT;
+ break;
+
+ case INTRINSIC_LT_OS:
+ op = INTRINSIC_LT;
+ break;
+
+ default:
+ break;
+ }
+
+ switch (op)
+ {
+ case INTRINSIC_EQ:
+ case INTRINSIC_GE:
+ case INTRINSIC_LE:
+ case INTRINSIC_NE:
+ case INTRINSIC_GT:
+ case INTRINSIC_LT:
+ changed = optimize_comparison (e, op);
+
+ gcc_fallthrough ();
+ /* Look at array constructors. */
+ case INTRINSIC_PLUS:
+ case INTRINSIC_MINUS:
+ case INTRINSIC_TIMES:
+ case INTRINSIC_DIVIDE:
+ return combine_array_constructor (e) || changed;
+
+ default:
+ break;
+ }
+
+ return false;
+}
+
+
+/* Return true if a constant string contains only blanks. */
+
+static bool
+is_empty_string (gfc_expr *e)
+{
+ int i;
+
+ if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
+ return false;
+
+ for (i=0; i < e->value.character.length; i++)
+ {
+ if (e->value.character.string[i] != ' ')
+ return false;
+ }
+
+ return true;
+}
+
+
+/* Insert a call to the intrinsic len_trim. Use a different name for
+ the symbol tree so we don't run into trouble when the user has
+ renamed len_trim for some reason. */
+
+static gfc_expr*
+get_len_trim_call (gfc_expr *str, int kind)
+{
+ gfc_expr *fcn;
+ gfc_actual_arglist *actual_arglist, *next;
+
+ fcn = gfc_get_expr ();
+ fcn->expr_type = EXPR_FUNCTION;
+ fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
+ actual_arglist = gfc_get_actual_arglist ();
+ actual_arglist->expr = str;
+ next = gfc_get_actual_arglist ();
+ next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, kind);
+ actual_arglist->next = next;
+
+ fcn->value.function.actual = actual_arglist;
+ fcn->where = str->where;
+ fcn->ts.type = BT_INTEGER;
+ fcn->ts.kind = gfc_charlen_int_kind;
+
+ gfc_get_sym_tree ("__internal_len_trim", current_ns, &fcn->symtree, false);
+ fcn->symtree->n.sym->ts = fcn->ts;
+ fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+ fcn->symtree->n.sym->attr.function = 1;
+ fcn->symtree->n.sym->attr.elemental = 1;
+ fcn->symtree->n.sym->attr.referenced = 1;
+ fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
+ gfc_commit_symbol (fcn->symtree->n.sym);
+
+ return fcn;
+}
+
+
+/* Optimize expressions for equality. */
+
+static bool
+optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
+{
+ gfc_expr *op1, *op2;
+ bool change;
+ int eq;
+ bool result;
+ gfc_actual_arglist *firstarg, *secondarg;
+
+ if (e->expr_type == EXPR_OP)
+ {
+ firstarg = NULL;
+ secondarg = NULL;
+ op1 = e->value.op.op1;
+ op2 = e->value.op.op2;
+ }
+ else if (e->expr_type == EXPR_FUNCTION)
+ {
+ /* One of the lexical comparison functions. */
+ firstarg = e->value.function.actual;
+ secondarg = firstarg->next;
+ op1 = firstarg->expr;
+ op2 = secondarg->expr;
+ }
+ else
+ gcc_unreachable ();
+
+ /* Strip off unneeded TRIM calls from string comparisons. */
+
+ change = remove_trim (op1);
+
+ if (remove_trim (op2))
+ change = true;
+
+ /* An expression of type EXPR_CONSTANT is only valid for scalars. */
+ /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
+ handles them well). However, there are also cases that need a non-scalar
+ argument. For example the any intrinsic. See PR 45380. */
+ if (e->rank > 0)
+ return change;
+
+ /* Replace a == '' with len_trim(a) == 0 and a /= '' with
+ len_trim(a) != 0 */
+ if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
+ && (op == INTRINSIC_EQ || op == INTRINSIC_NE))
+ {
+ bool empty_op1, empty_op2;
+ empty_op1 = is_empty_string (op1);
+ empty_op2 = is_empty_string (op2);
+
+ if (empty_op1 || empty_op2)
+ {
+ gfc_expr *fcn;
+ gfc_expr *zero;
+ gfc_expr *str;
+
+ /* This can only happen when an error for comparing
+ characters of different kinds has already been issued. */
+ if (empty_op1 && empty_op2)
+ return false;
+
+ zero = gfc_get_int_expr (gfc_charlen_int_kind, &e->where, 0);
+ str = empty_op1 ? op2 : op1;
+
+ fcn = get_len_trim_call (str, gfc_charlen_int_kind);
+
+
+ if (empty_op1)
+ gfc_free_expr (op1);
+ else
+ gfc_free_expr (op2);
+
+ op1 = fcn;
+ op2 = zero;
+ e->value.op.op1 = fcn;
+ e->value.op.op2 = zero;
+ }
+ }
+
+
+ /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
+
+ if (flag_finite_math_only
+ || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
+ && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX))
+ {
+ eq = gfc_dep_compare_expr (op1, op2);
+ if (eq <= -2)
+ {
+ /* Replace A // B < A // C with B < C, and A // B < C // B
+ with A < C. */
+ if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
+ && op1->expr_type == EXPR_OP
+ && op1->value.op.op == INTRINSIC_CONCAT
+ && op2->expr_type == EXPR_OP
+ && op2->value.op.op == INTRINSIC_CONCAT)
+ {
+ gfc_expr *op1_left = op1->value.op.op1;
+ gfc_expr *op2_left = op2->value.op.op1;
+ gfc_expr *op1_right = op1->value.op.op2;
+ gfc_expr *op2_right = op2->value.op.op2;
+
+ if (gfc_dep_compare_expr (op1_left, op2_left) == 0)
+ {
+ /* Watch out for 'A ' // x vs. 'A' // x. */
+
+ if (op1_left->expr_type == EXPR_CONSTANT
+ && op2_left->expr_type == EXPR_CONSTANT
+ && op1_left->value.character.length
+ != op2_left->value.character.length)
+ return change;
+ else
+ {
+ free (op1_left);
+ free (op2_left);
+ if (firstarg)
+ {
+ firstarg->expr = op1_right;
+ secondarg->expr = op2_right;
+ }
+ else
+ {
+ e->value.op.op1 = op1_right;
+ e->value.op.op2 = op2_right;
+ }
+ optimize_comparison (e, op);
+ return true;
+ }
+ }
+ if (gfc_dep_compare_expr (op1_right, op2_right) == 0)
+ {
+ free (op1_right);
+ free (op2_right);
+ if (firstarg)
+ {
+ firstarg->expr = op1_left;
+ secondarg->expr = op2_left;
+ }
+ else
+ {
+ e->value.op.op1 = op1_left;
+ e->value.op.op2 = op2_left;
+ }
+
+ optimize_comparison (e, op);
+ return true;
+ }
+ }
+ }
+ else
+ {
+ /* eq can only be -1, 0 or 1 at this point. */
+ switch (op)
+ {
+ case INTRINSIC_EQ:
+ result = eq == 0;
+ break;
+
+ case INTRINSIC_GE:
+ result = eq >= 0;
+ break;
+
+ case INTRINSIC_LE:
+ result = eq <= 0;
+ break;
+
+ case INTRINSIC_NE:
+ result = eq != 0;
+ break;
+
+ case INTRINSIC_GT:
+ result = eq > 0;
+ break;
+
+ case INTRINSIC_LT:
+ result = eq < 0;
+ break;
+
+ default:
+ gfc_internal_error ("illegal OP in optimize_comparison");
+ break;
+ }
+
+ /* Replace the expression by a constant expression. The typespec
+ and where remains the way it is. */
+ free (op1);
+ free (op2);
+ e->expr_type = EXPR_CONSTANT;
+ e->value.logical = result;
+ return true;
+ }
+ }
+
+ return change;
+}
+
+/* Optimize a trim function by replacing it with an equivalent substring
+ involving a call to len_trim. This only works for expressions where
+ variables are trimmed. Return true if anything was modified. */
+
+static bool
+optimize_trim (gfc_expr *e)
+{
+ gfc_expr *a;
+ gfc_ref *ref;
+ gfc_expr *fcn;
+ gfc_ref **rr = NULL;
+
+ /* Don't do this optimization within an argument list, because
+ otherwise aliasing issues may occur. */
+
+ if (count_arglist != 1)
+ return false;
+
+ if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION
+ || e->value.function.isym == NULL
+ || e->value.function.isym->id != GFC_ISYM_TRIM)
+ return false;
+
+ a = e->value.function.actual->expr;
+
+ if (a->expr_type != EXPR_VARIABLE)
+ return false;
+
+ /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
+
+ if (a->symtree->n.sym->attr.allocatable)
+ return false;
+
+ /* Follow all references to find the correct place to put the newly
+ created reference. FIXME: Also handle substring references and
+ array references. Array references cause strange regressions at
+ the moment. */
+
+ if (a->ref)
+ {
+ for (rr = &(a->ref); *rr; rr = &((*rr)->next))
+ {
+ if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY)
+ return false;
+ }
+ }
+
+ strip_function_call (e);
+
+ if (e->ref == NULL)
+ rr = &(e->ref);
+
+ /* Create the reference. */
+
+ ref = gfc_get_ref ();
+ ref->type = REF_SUBSTRING;
+
+ /* Set the start of the reference. */
+
+ ref->u.ss.start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
+
+ /* Build the function call to len_trim(x, gfc_default_integer_kind). */
+
+ fcn = get_len_trim_call (gfc_copy_expr (e), gfc_charlen_int_kind);
+
+ /* Set the end of the reference to the call to len_trim. */
+
+ ref->u.ss.end = fcn;
+ gcc_assert (rr != NULL && *rr == NULL);
+ *rr = ref;
+ return true;
+}
+
+/* Optimize minloc(b), where b is rank 1 array, into
+ (/ minloc(b, dim=1) /), and similarly for maxloc,
+ as the latter forms are expanded inline. */
+
+static void
+optimize_minmaxloc (gfc_expr **e)
+{
+ gfc_expr *fn = *e;
+ gfc_actual_arglist *a;
+ char *name, *p;
+
+ if (fn->rank != 1
+ || fn->value.function.actual == NULL
+ || fn->value.function.actual->expr == NULL
+ || fn->value.function.actual->expr->rank != 1)
+ return;
+
+ *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where);
+ (*e)->shape = fn->shape;
+ fn->rank = 0;
+ fn->shape = NULL;
+ gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where);
+
+ name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1);
+ strcpy (name, fn->value.function.name);
+ p = strstr (name, "loc0");
+ p[3] = '1';
+ fn->value.function.name = gfc_get_string ("%s", name);
+ if (fn->value.function.actual->next)
+ {
+ a = fn->value.function.actual->next;
+ gcc_assert (a->expr == NULL);
+ }
+ else
+ {
+ a = gfc_get_actual_arglist ();
+ fn->value.function.actual->next = a;
+ }
+ a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &fn->where);
+ mpz_set_ui (a->expr->value.integer, 1);
+}
+
+/* Data package to hand down for DO loop checks in a contained
+ procedure. */
+typedef struct contained_info
+{
+ gfc_symbol *do_var;
+ gfc_symbol *procedure;
+ locus where_do;
+} contained_info;
+
+static enum gfc_exec_op last_io_op;
+
+/* Callback function to check for INTENT(OUT) and INTENT(INOUT) in a
+ contained function call. */
+
+static int
+doloop_contained_function_call (gfc_expr **e,
+ int *walk_subtrees ATTRIBUTE_UNUSED, void *data)
+{
+ gfc_expr *expr = *e;
+ gfc_formal_arglist *f;
+ gfc_actual_arglist *a;
+ gfc_symbol *sym, *do_var;
+ contained_info *info;
+
+ if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym
+ || expr->value.function.esym == NULL)
+ return 0;
+
+ sym = expr->value.function.esym;
+ f = gfc_sym_get_dummy_args (sym);
+ if (f == NULL)
+ return 0;
+
+ info = (contained_info *) data;
+ do_var = info->do_var;
+ a = expr->value.function.actual;
+
+ while (a && f)
+ {
+ if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var)
+ {
+ if (f->sym->attr.intent == INTENT_OUT)
+ {
+ gfc_error_now ("Index variable %qs set to undefined as "
+ "INTENT(OUT) argument at %L in procedure %qs "
+ "called from within DO loop at %L", do_var->name,
+ &a->expr->where, info->procedure->name,
+ &info->where_do);
+ return 1;
+ }
+ else if (f->sym->attr.intent == INTENT_INOUT)
+ {
+ gfc_error_now ("Index variable %qs not definable as "
+ "INTENT(INOUT) argument at %L in procedure %qs "
+ "called from within DO loop at %L", do_var->name,
+ &a->expr->where, info->procedure->name,
+ &info->where_do);
+ return 1;
+ }
+ }
+ a = a->next;
+ f = f->next;
+ }
+ return 0;
+}
+
+/* Callback function that goes through the code in a contained
+ procedure to make sure it does not change a variable in a DO
+ loop. */
+
+static int
+doloop_contained_procedure_code (gfc_code **c,
+ int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data)
+{
+ gfc_code *co = *c;
+ contained_info *info = (contained_info *) data;
+ gfc_symbol *do_var = info->do_var;
+ const char *errmsg = _("Index variable %qs redefined at %L in procedure %qs "
+ "called from within DO loop at %L");
+ static enum gfc_exec_op saved_io_op;
+
+ switch (co->op)
+ {
+ case EXEC_ASSIGN:
+ if (co->expr1->symtree && co->expr1->symtree->n.sym == do_var)
+ gfc_error_now (errmsg, do_var->name, &co->loc, info->procedure->name,
+ &info->where_do);
+ break;
+
+ case EXEC_DO:
+ if (co->ext.iterator && co->ext.iterator->var
+ && co->ext.iterator->var->symtree->n.sym == do_var)
+ gfc_error (errmsg, do_var->name, &co->loc, info->procedure->name,
+ &info->where_do);
+ break;
+
+ case EXEC_READ:
+ case EXEC_WRITE:
+ case EXEC_INQUIRE:
+ case EXEC_IOLENGTH:
+ saved_io_op = last_io_op;
+ last_io_op = co->op;
+ break;
+
+ case EXEC_OPEN:
+ if (co->ext.open && co->ext.open->iostat
+ && co->ext.open->iostat->symtree->n.sym == do_var)
+ gfc_error_now (errmsg, do_var->name, &co->ext.open->iostat->where,
+ info->procedure->name, &info->where_do);
+ break;
+
+ case EXEC_CLOSE:
+ if (co->ext.close && co->ext.close->iostat
+ && co->ext.close->iostat->symtree->n.sym == do_var)
+ gfc_error_now (errmsg, do_var->name, &co->ext.close->iostat->where,
+ info->procedure->name, &info->where_do);
+ break;
+
+ case EXEC_TRANSFER:
+ switch (last_io_op)
+ {
+
+ case EXEC_INQUIRE:
+#define CHECK_INQ(a) do { if (co->ext.inquire && \
+ co->ext.inquire->a && \
+ co->ext.inquire->a->symtree->n.sym == do_var) \
+ gfc_error_now (errmsg, do_var->name, \
+ &co->ext.inquire->a->where, \
+ info->procedure->name, \
+ &info->where_do); \
+ } while (0)
+
+ CHECK_INQ(iostat);
+ CHECK_INQ(number);
+ CHECK_INQ(position);
+ CHECK_INQ(recl);
+ CHECK_INQ(position);
+ CHECK_INQ(iolength);
+ CHECK_INQ(strm_pos);
+ break;
+#undef CHECK_INQ
+
+ case EXEC_READ:
+ if (co->expr1 && co->expr1->symtree
+ && co->expr1->symtree->n.sym == do_var)
+ gfc_error_now (errmsg, do_var->name, &co->expr1->where,
+ info->procedure->name, &info->where_do);
+
+ /* Fallthrough. */
+
+ case EXEC_WRITE:
+ if (co->ext.dt && co->ext.dt->iostat && co->ext.dt->iostat->symtree
+ && co->ext.dt->iostat->symtree->n.sym == do_var)
+ gfc_error_now (errmsg, do_var->name, &co->ext.dt->iostat->where,
+ info->procedure->name, &info->where_do);
+ break;
+
+ case EXEC_IOLENGTH:
+ if (co->expr1 && co->expr1->symtree
+ && co->expr1->symtree->n.sym == do_var)
+ gfc_error_now (errmsg, do_var->name, &co->expr1->where,
+ info->procedure->name, &info->where_do);
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+ break;
+
+ case EXEC_DT_END:
+ last_io_op = saved_io_op;
+ break;
+
+ case EXEC_CALL:
+ gfc_formal_arglist *f;
+ gfc_actual_arglist *a;
+
+ f = gfc_sym_get_dummy_args (co->resolved_sym);
+ if (f == NULL)
+ break;
+ a = co->ext.actual;
+ /* Slightly different error message here. If there is an error,
+ return 1 to avoid an infinite loop. */
+ while (a && f)
+ {
+ if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var)
+ {
+ if (f->sym->attr.intent == INTENT_OUT)
+ {
+ gfc_error_now ("Index variable %qs set to undefined as "
+ "INTENT(OUT) argument at %L in subroutine %qs "
+ "called from within DO loop at %L",
+ do_var->name, &a->expr->where,
+ info->procedure->name, &info->where_do);
+ return 1;
+ }
+ else if (f->sym->attr.intent == INTENT_INOUT)
+ {
+ gfc_error_now ("Index variable %qs not definable as "
+ "INTENT(INOUT) argument at %L in subroutine %qs "
+ "called from within DO loop at %L", do_var->name,
+ &a->expr->where, info->procedure->name,
+ &info->where_do);
+ return 1;
+ }
+ }
+ a = a->next;
+ f = f->next;
+ }
+ break;
+ default:
+ break;
+ }
+ return 0;
+}
+
+/* Callback function for code checking that we do not pass a DO variable to an
+ INTENT(OUT) or INTENT(INOUT) dummy variable. */
+
+static int
+doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_code *co;
+ int i;
+ gfc_formal_arglist *f;
+ gfc_actual_arglist *a;
+ gfc_code *cl;
+ do_t loop, *lp;
+ bool seen_goto;
+
+ co = *c;
+
+ /* If the doloop_list grew, we have to truncate it here. */
+
+ if ((unsigned) doloop_level < doloop_list.length())
+ doloop_list.truncate (doloop_level);
+
+ seen_goto = false;
+ switch (co->op)
+ {
+ case EXEC_DO:
+
+ if (co->ext.iterator && co->ext.iterator->var)
+ loop.c = co;
+ else
+ loop.c = NULL;
+
+ loop.branch_level = if_level + select_level;
+ loop.seen_goto = false;
+ doloop_list.safe_push (loop);
+ break;
+
+ /* If anything could transfer control away from a suspicious
+ subscript, make sure to set seen_goto in the current DO loop
+ (if any). */
+ case EXEC_GOTO:
+ case EXEC_EXIT:
+ case EXEC_STOP:
+ case EXEC_ERROR_STOP:
+ case EXEC_CYCLE:
+ seen_goto = true;
+ break;
+
+ case EXEC_OPEN:
+ if (co->ext.open->err)
+ seen_goto = true;
+ break;
+
+ case EXEC_CLOSE:
+ if (co->ext.close->err)
+ seen_goto = true;
+ break;
+
+ case EXEC_BACKSPACE:
+ case EXEC_ENDFILE:
+ case EXEC_REWIND:
+ case EXEC_FLUSH:
+
+ if (co->ext.filepos->err)
+ seen_goto = true;
+ break;
+
+ case EXEC_INQUIRE:
+ if (co->ext.filepos->err)
+ seen_goto = true;
+ break;
+
+ case EXEC_READ:
+ case EXEC_WRITE:
+ if (co->ext.dt->err || co->ext.dt->end || co->ext.dt->eor)
+ seen_goto = true;
+ break;
+
+ case EXEC_WAIT:
+ if (co->ext.wait->err || co->ext.wait->end || co->ext.wait->eor)
+ loop.seen_goto = true;
+ break;
+
+ case EXEC_CALL:
+ if (co->resolved_sym == NULL)
+ break;
+
+ /* Test if somebody stealthily changes the DO variable from
+ under us by changing it in a host-associated procedure. */
+ if (co->resolved_sym->attr.contained)
+ {
+ FOR_EACH_VEC_ELT (doloop_list, i, lp)
+ {
+ gfc_symbol *sym = co->resolved_sym;
+ contained_info info;
+ gfc_namespace *ns;
+
+ cl = lp->c;
+ info.do_var = cl->ext.iterator->var->symtree->n.sym;
+ info.procedure = co->resolved_sym; /* sym? */
+ info.where_do = co->loc;
+ /* Look contained procedures under the namespace of the
+ variable. */
+ for (ns = info.do_var->ns->contained; ns; ns = ns->sibling)
+ if (ns->proc_name && ns->proc_name == sym)
+ gfc_code_walker (&ns->code, doloop_contained_procedure_code,
+ doloop_contained_function_call, &info);
+ }
+ }
+
+ f = gfc_sym_get_dummy_args (co->resolved_sym);
+
+ /* Withot a formal arglist, there is only unknown INTENT,
+ which we don't check for. */
+ if (f == NULL)
+ break;
+
+ a = co->ext.actual;
+
+ while (a && f)
+ {
+ FOR_EACH_VEC_ELT (doloop_list, i, lp)
+ {
+ gfc_symbol *do_sym;
+ cl = lp->c;
+
+ if (cl == NULL)
+ break;
+
+ do_sym = cl->ext.iterator->var->symtree->n.sym;
+
+ if (a->expr && a->expr->symtree && f->sym
+ && a->expr->symtree->n.sym == do_sym)
+ {
+ if (f->sym->attr.intent == INTENT_OUT)
+ gfc_error_now ("Variable %qs at %L set to undefined "
+ "value inside loop beginning at %L as "
+ "INTENT(OUT) argument to subroutine %qs",
+ do_sym->name, &a->expr->where,
+ &(doloop_list[i].c->loc),
+ co->symtree->n.sym->name);
+ else if (f->sym->attr.intent == INTENT_INOUT)
+ gfc_error_now ("Variable %qs at %L not definable inside "
+ "loop beginning at %L as INTENT(INOUT) "
+ "argument to subroutine %qs",
+ do_sym->name, &a->expr->where,
+ &(doloop_list[i].c->loc),
+ co->symtree->n.sym->name);
+ }
+ }
+ a = a->next;
+ f = f->next;
+ }
+
+ break;
+
+ default:
+ break;
+ }
+ if (seen_goto && doloop_level > 0)
+ doloop_list[doloop_level-1].seen_goto = true;
+
+ return 0;
+}
+
+/* Callback function to warn about different things within DO loops. */
+
+static int
+do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ do_t *last;
+
+ if (doloop_list.length () == 0)
+ return 0;
+
+ if ((*e)->expr_type == EXPR_FUNCTION)
+ do_intent (e);
+
+ last = &doloop_list.last();
+ if (last->seen_goto && !warn_do_subscript)
+ return 0;
+
+ if ((*e)->expr_type == EXPR_VARIABLE)
+ do_subscript (e);
+
+ return 0;
+}
+
+typedef struct
+{
+ gfc_symbol *sym;
+ mpz_t val;
+} insert_index_t;
+
+/* Callback function - if the expression is the variable in data->sym,
+ replace it with a constant from data->val. */
+
+static int
+callback_insert_index (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data)
+{
+ insert_index_t *d;
+ gfc_expr *ex, *n;
+
+ ex = (*e);
+ if (ex->expr_type != EXPR_VARIABLE)
+ return 0;
+
+ d = (insert_index_t *) data;
+ if (ex->symtree->n.sym != d->sym)
+ return 0;
+
+ n = gfc_get_constant_expr (BT_INTEGER, ex->ts.kind, &ex->where);
+ mpz_set (n->value.integer, d->val);
+
+ gfc_free_expr (ex);
+ *e = n;
+ return 0;
+}
+
+/* In the expression e, replace occurrences of the variable sym with
+ val. If this results in a constant expression, return true and
+ return the value in ret. Return false if the expression already
+ is a constant. Caller has to clear ret in that case. */
+
+static bool
+insert_index (gfc_expr *e, gfc_symbol *sym, mpz_t val, mpz_t ret)
+{
+ gfc_expr *n;
+ insert_index_t data;
+ bool rc;
+
+ if (e->expr_type == EXPR_CONSTANT)
+ return false;
+
+ n = gfc_copy_expr (e);
+ data.sym = sym;
+ mpz_init_set (data.val, val);
+ gfc_expr_walker (&n, callback_insert_index, (void *) &data);
+
+ /* Suppress errors here - we could get errors here such as an
+ out of bounds access for arrays, see PR 90563. */
+ gfc_push_suppress_errors ();
+ gfc_simplify_expr (n, 0);
+ gfc_pop_suppress_errors ();
+
+ if (n->expr_type == EXPR_CONSTANT)
+ {
+ rc = true;
+ mpz_init_set (ret, n->value.integer);
+ }
+ else
+ rc = false;
+
+ mpz_clear (data.val);
+ gfc_free_expr (n);
+ return rc;
+
+}
+
+/* Check array subscripts for possible out-of-bounds accesses in DO
+ loops with constant bounds. */
+
+static int
+do_subscript (gfc_expr **e)
+{
+ gfc_expr *v;
+ gfc_array_ref *ar;
+ gfc_ref *ref;
+ int i,j;
+ gfc_code *dl;
+ do_t *lp;
+
+ v = *e;
+ /* Constants are already checked. */
+ if (v->expr_type == EXPR_CONSTANT)
+ return 0;
+
+ /* Wrong warnings will be generated in an associate list. */
+ if (in_assoc_list)
+ return 0;
+
+ /* We already warned about this. */
+ if (v->do_not_warn)
+ return 0;
+
+ v->do_not_warn = 1;
+
+ for (ref = v->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
+ {
+ ar = & ref->u.ar;
+ FOR_EACH_VEC_ELT (doloop_list, j, lp)
+ {
+ gfc_symbol *do_sym;
+ mpz_t do_start, do_step, do_end;
+ bool have_do_start, have_do_end;
+ bool error_not_proven;
+ int warn;
+ int sgn;
+
+ dl = lp->c;
+ if (dl == NULL)
+ break;
+
+ /* If we are within a branch, or a goto or equivalent
+ was seen in the DO loop before, then we cannot prove that
+ this expression is actually evaluated. Don't do anything
+ unless we want to see it all. */
+ error_not_proven = lp->seen_goto
+ || lp->branch_level < if_level + select_level;
+
+ if (error_not_proven && !warn_do_subscript)
+ break;
+
+ if (error_not_proven)
+ warn = OPT_Wdo_subscript;
+ else
+ warn = 0;
+
+ do_sym = dl->ext.iterator->var->symtree->n.sym;
+ if (do_sym->ts.type != BT_INTEGER)
+ continue;
+
+ /* If we do not know about the stepsize, the loop may be zero trip.
+ Do not warn in this case. */
+
+ if (dl->ext.iterator->step->expr_type == EXPR_CONSTANT)
+ {
+ sgn = mpz_cmp_ui (dl->ext.iterator->step->value.integer, 0);
+ /* This can happen, but then the error has been
+ reported previously. */
+ if (sgn == 0)
+ continue;
+
+ mpz_init_set (do_step, dl->ext.iterator->step->value.integer);
+ }
+
+ else
+ continue;
+
+ if (dl->ext.iterator->start->expr_type == EXPR_CONSTANT)
+ {
+ have_do_start = true;
+ mpz_init_set (do_start, dl->ext.iterator->start->value.integer);
+ }
+ else
+ have_do_start = false;
+
+ if (dl->ext.iterator->end->expr_type == EXPR_CONSTANT)
+ {
+ have_do_end = true;
+ mpz_init_set (do_end, dl->ext.iterator->end->value.integer);
+ }
+ else
+ have_do_end = false;
+
+ if (!have_do_start && !have_do_end)
+ return 0;
+
+ /* No warning inside a zero-trip loop. */
+ if (have_do_start && have_do_end)
+ {
+ int cmp;
+
+ cmp = mpz_cmp (do_end, do_start);
+ if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
+ break;
+ }
+
+ /* May have to correct the end value if the step does not equal
+ one. */
+ if (have_do_start && have_do_end && mpz_cmp_ui (do_step, 1) != 0)
+ {
+ mpz_t diff, rem;
+
+ mpz_init (diff);
+ mpz_init (rem);
+ mpz_sub (diff, do_end, do_start);
+ mpz_tdiv_r (rem, diff, do_step);
+ mpz_sub (do_end, do_end, rem);
+ mpz_clear (diff);
+ mpz_clear (rem);
+ }
+
+ for (i = 0; i< ar->dimen; i++)
+ {
+ mpz_t val;
+ if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_start
+ && insert_index (ar->start[i], do_sym, do_start, val))
+ {
+ if (ar->as->lower[i]
+ && ar->as->lower[i]->expr_type == EXPR_CONSTANT
+ && ar->as->lower[i]->ts.type == BT_INTEGER
+ && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0)
+ gfc_warning (warn, "Array reference at %L out of bounds "
+ "(%ld < %ld) in loop beginning at %L",
+ &ar->start[i]->where, mpz_get_si (val),
+ mpz_get_si (ar->as->lower[i]->value.integer),
+ &doloop_list[j].c->loc);
+
+ if (ar->as->upper[i]
+ && ar->as->upper[i]->expr_type == EXPR_CONSTANT
+ && ar->as->upper[i]->ts.type == BT_INTEGER
+ && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0)
+ gfc_warning (warn, "Array reference at %L out of bounds "
+ "(%ld > %ld) in loop beginning at %L",
+ &ar->start[i]->where, mpz_get_si (val),
+ mpz_get_si (ar->as->upper[i]->value.integer),
+ &doloop_list[j].c->loc);
+
+ mpz_clear (val);
+ }
+
+ if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_end
+ && insert_index (ar->start[i], do_sym, do_end, val))
+ {
+ if (ar->as->lower[i]
+ && ar->as->lower[i]->expr_type == EXPR_CONSTANT
+ && ar->as->lower[i]->ts.type == BT_INTEGER
+ && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0)
+ gfc_warning (warn, "Array reference at %L out of bounds "
+ "(%ld < %ld) in loop beginning at %L",
+ &ar->start[i]->where, mpz_get_si (val),
+ mpz_get_si (ar->as->lower[i]->value.integer),
+ &doloop_list[j].c->loc);
+
+ if (ar->as->upper[i]
+ && ar->as->upper[i]->expr_type == EXPR_CONSTANT
+ && ar->as->upper[i]->ts.type == BT_INTEGER
+ && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0)
+ gfc_warning (warn, "Array reference at %L out of bounds "
+ "(%ld > %ld) in loop beginning at %L",
+ &ar->start[i]->where, mpz_get_si (val),
+ mpz_get_si (ar->as->upper[i]->value.integer),
+ &doloop_list[j].c->loc);
+
+ mpz_clear (val);
+ }
+ }
+ }
+ }
+ }
+ return 0;
+}
+/* Function for functions checking that we do not pass a DO variable
+ to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
+
+static int
+do_intent (gfc_expr **e)
+{
+ gfc_formal_arglist *f;
+ gfc_actual_arglist *a;
+ gfc_expr *expr;
+ gfc_code *dl;
+ do_t *lp;
+ int i;
+ gfc_symbol *sym;
+
+ expr = *e;
+ if (expr->expr_type != EXPR_FUNCTION)
+ return 0;
+
+ /* Intrinsic functions don't modify their arguments. */
+
+ if (expr->value.function.isym)
+ return 0;
+
+ sym = expr->value.function.esym;
+ if (sym == NULL)
+ return 0;
+
+ if (sym->attr.contained)
+ {
+ FOR_EACH_VEC_ELT (doloop_list, i, lp)
+ {
+ contained_info info;
+ gfc_namespace *ns;
+
+ dl = lp->c;
+ info.do_var = dl->ext.iterator->var->symtree->n.sym;
+ info.procedure = sym;
+ info.where_do = expr->where;
+ /* Look contained procedures under the namespace of the
+ variable. */
+ for (ns = info.do_var->ns->contained; ns; ns = ns->sibling)
+ if (ns->proc_name && ns->proc_name == sym)
+ gfc_code_walker (&ns->code, doloop_contained_procedure_code,
+ dummy_expr_callback, &info);
+ }
+ }
+
+ f = gfc_sym_get_dummy_args (sym);
+
+ /* Without a formal arglist, there is only unknown INTENT,
+ which we don't check for. */
+ if (f == NULL)
+ return 0;
+
+ a = expr->value.function.actual;
+
+ while (a && f)
+ {
+ FOR_EACH_VEC_ELT (doloop_list, i, lp)
+ {
+ gfc_symbol *do_sym;
+ dl = lp->c;
+ if (dl == NULL)
+ break;
+
+ do_sym = dl->ext.iterator->var->symtree->n.sym;
+
+ if (a->expr && a->expr->symtree
+ && a->expr->symtree->n.sym == do_sym)
+ {
+ if (f->sym->attr.intent == INTENT_OUT)
+ gfc_error_now ("Variable %qs at %L set to undefined value "
+ "inside loop beginning at %L as INTENT(OUT) "
+ "argument to function %qs", do_sym->name,
+ &a->expr->where, &doloop_list[i].c->loc,
+ expr->symtree->n.sym->name);
+ else if (f->sym->attr.intent == INTENT_INOUT)
+ gfc_error_now ("Variable %qs at %L not definable inside loop"
+ " beginning at %L as INTENT(INOUT) argument to"
+ " function %qs", do_sym->name,
+ &a->expr->where, &doloop_list[i].c->loc,
+ expr->symtree->n.sym->name);
+ }
+ }
+ a = a->next;
+ f = f->next;
+ }
+
+ return 0;
+}
+
+static void
+doloop_warn (gfc_namespace *ns)
+{
+ gfc_code_walker (&ns->code, doloop_code, do_function, NULL);
+
+ for (ns = ns->contained; ns; ns = ns->sibling)
+ {
+ if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
+ doloop_warn (ns);
+ }
+}
+
+/* This selction deals with inlining calls to MATMUL. */
+
+/* Replace calls to matmul outside of straight assignments with a temporary
+ variable so that later inlining will work. */
+
+static int
+matmul_to_var_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data)
+{
+ gfc_expr *e, *n;
+ bool *found = (bool *) data;
+
+ e = *ep;
+
+ if (e->expr_type != EXPR_FUNCTION
+ || e->value.function.isym == NULL
+ || e->value.function.isym->id != GFC_ISYM_MATMUL)
+ return 0;
+
+ if (forall_level > 0 || iterator_level > 0 || in_omp_workshare
+ || in_omp_atomic || in_where || in_assoc_list)
+ return 0;
+
+ /* Check if this is already in the form c = matmul(a,b). */
+
+ if ((*current_code)->expr2 == e)
+ return 0;
+
+ n = create_var (e, "matmul");
+
+ /* If create_var is unable to create a variable (for example if
+ -fno-realloc-lhs is in force with a variable that does not have bounds
+ known at compile-time), just return. */
+
+ if (n == NULL)
+ return 0;
+
+ *ep = n;
+ *found = true;
+ return 0;
+}
+
+/* Set current_code and associated variables so that matmul_to_var_expr can
+ work. */
+
+static int
+matmul_to_var_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ if (current_code != c)
+ {
+ current_code = c;
+ inserted_block = NULL;
+ changed_statement = NULL;
+ }
+
+ return 0;
+}
+
+
+/* Take a statement of the shape c = matmul(a,b) and create temporaries
+ for a and b if there is a dependency between the arguments and the
+ result variable or if a or b are the result of calculations that cannot
+ be handled by the inliner. */
+
+static int
+matmul_temp_args (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_expr *expr1, *expr2;
+ gfc_code *co;
+ gfc_actual_arglist *a, *b;
+ bool a_tmp, b_tmp;
+ gfc_expr *matrix_a, *matrix_b;
+ bool conjg_a, conjg_b, transpose_a, transpose_b;
+
+ co = *c;
+
+ if (co->op != EXEC_ASSIGN)
+ return 0;
+
+ if (forall_level > 0 || iterator_level > 0 || in_omp_workshare
+ || in_omp_atomic || in_where)
+ return 0;
+
+ /* This has some duplication with inline_matmul_assign. This
+ is because the creation of temporary variables could still fail,
+ and inline_matmul_assign still needs to be able to handle these
+ cases. */
+ expr1 = co->expr1;
+ expr2 = co->expr2;
+
+ if (expr2->expr_type != EXPR_FUNCTION
+ || expr2->value.function.isym == NULL
+ || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
+ return 0;
+
+ a_tmp = false;
+ a = expr2->value.function.actual;
+ matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
+ if (matrix_a != NULL)
+ {
+ if (matrix_a->expr_type == EXPR_VARIABLE
+ && (gfc_check_dependency (matrix_a, expr1, true)
+ || gfc_has_dimen_vector_ref (matrix_a)))
+ a_tmp = true;
+ }
+ else
+ a_tmp = true;
+
+ b_tmp = false;
+ b = a->next;
+ matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
+ if (matrix_b != NULL)
+ {
+ if (matrix_b->expr_type == EXPR_VARIABLE
+ && (gfc_check_dependency (matrix_b, expr1, true)
+ || gfc_has_dimen_vector_ref (matrix_b)))
+ b_tmp = true;
+ }
+ else
+ b_tmp = true;
+
+ if (!a_tmp && !b_tmp)
+ return 0;
+
+ current_code = c;
+ inserted_block = NULL;
+ changed_statement = NULL;
+ if (a_tmp)
+ {
+ gfc_expr *at;
+ at = create_var (a->expr,"mma");
+ if (at)
+ a->expr = at;
+ }
+ if (b_tmp)
+ {
+ gfc_expr *bt;
+ bt = create_var (b->expr,"mmb");
+ if (bt)
+ b->expr = bt;
+ }
+ return 0;
+}
+
+/* Auxiliary function to build and simplify an array inquiry function.
+ dim is zero-based. */
+
+static gfc_expr *
+get_array_inq_function (gfc_isym_id id, gfc_expr *e, int dim, int okind = 0)
+{
+ gfc_expr *fcn;
+ gfc_expr *dim_arg, *kind;
+ const char *name;
+ gfc_expr *ec;
+
+ switch (id)
+ {
+ case GFC_ISYM_LBOUND:
+ name = "_gfortran_lbound";
+ break;
+
+ case GFC_ISYM_UBOUND:
+ name = "_gfortran_ubound";
+ break;
+
+ case GFC_ISYM_SIZE:
+ name = "_gfortran_size";
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+
+ dim_arg = gfc_get_int_expr (gfc_default_integer_kind, &e->where, dim);
+ if (okind != 0)
+ kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
+ okind);
+ else
+ kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
+ gfc_index_integer_kind);
+
+ ec = gfc_copy_expr (e);
+
+ /* No bounds checking, this will be done before the loops if -fcheck=bounds
+ is in effect. */
+ ec->no_bounds_check = 1;
+ fcn = gfc_build_intrinsic_call (current_ns, id, name, e->where, 3,
+ ec, dim_arg, kind);
+ gfc_simplify_expr (fcn, 0);
+ fcn->no_bounds_check = 1;
+ return fcn;
+}
+
+/* Builds a logical expression. */
+
+static gfc_expr*
+build_logical_expr (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2)
+{
+ gfc_typespec ts;
+ gfc_expr *res;
+
+ ts.type = BT_LOGICAL;
+ ts.kind = gfc_default_logical_kind;
+ res = gfc_get_expr ();
+ res->where = e1->where;
+ res->expr_type = EXPR_OP;
+ res->value.op.op = op;
+ res->value.op.op1 = e1;
+ res->value.op.op2 = e2;
+ res->ts = ts;
+
+ return res;
+}
+
+
+/* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
+ compatible typespecs. */
+
+static gfc_expr *
+get_operand (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2)
+{
+ gfc_expr *res;
+
+ res = gfc_get_expr ();
+ res->ts = e1->ts;
+ res->where = e1->where;
+ res->expr_type = EXPR_OP;
+ res->value.op.op = op;
+ res->value.op.op1 = e1;
+ res->value.op.op2 = e2;
+ gfc_simplify_expr (res, 0);
+ return res;
+}
+
+/* Generate the IF statement for a runtime check if we want to do inlining or
+ not - putting in the code for both branches and putting it into the syntax
+ tree is the caller's responsibility. For fixed array sizes, this should be
+ removed by DCE. Only called for rank-two matrices A and B. */
+
+static gfc_code *
+inline_limit_check (gfc_expr *a, gfc_expr *b, int limit, int rank_a)
+{
+ gfc_expr *inline_limit;
+ gfc_code *if_1, *if_2, *else_2;
+ gfc_expr *b2, *a2, *a1, *m1, *m2;
+ gfc_typespec ts;
+ gfc_expr *cond;
+
+ gcc_assert (rank_a == 1 || rank_a == 2);
+
+ /* Calculation is done in real to avoid integer overflow. */
+
+ inline_limit = gfc_get_constant_expr (BT_REAL, gfc_default_real_kind,
+ &a->where);
+ mpfr_set_si (inline_limit->value.real, limit, GFC_RND_MODE);
+
+ /* Set the limit according to the rank. */
+ mpfr_pow_ui (inline_limit->value.real, inline_limit->value.real, rank_a + 1,
+ GFC_RND_MODE);
+
+ a1 = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
+
+ /* For a_rank = 1, must use one as the size of a along the second
+ dimension as to avoid too much code duplication. */
+
+ if (rank_a == 2)
+ a2 = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
+ else
+ a2 = gfc_get_int_expr (gfc_index_integer_kind, &a->where, 1);
+
+ b2 = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
+
+ gfc_clear_ts (&ts);
+ ts.type = BT_REAL;
+ ts.kind = gfc_default_real_kind;
+ gfc_convert_type_warn (a1, &ts, 2, 0);
+ gfc_convert_type_warn (a2, &ts, 2, 0);
+ gfc_convert_type_warn (b2, &ts, 2, 0);
+
+ m1 = get_operand (INTRINSIC_TIMES, a1, a2);
+ m2 = get_operand (INTRINSIC_TIMES, m1, b2);
+
+ cond = build_logical_expr (INTRINSIC_LE, m2, inline_limit);
+ gfc_simplify_expr (cond, 0);
+
+ else_2 = XCNEW (gfc_code);
+ else_2->op = EXEC_IF;
+ else_2->loc = a->where;
+
+ if_2 = XCNEW (gfc_code);
+ if_2->op = EXEC_IF;
+ if_2->expr1 = cond;
+ if_2->loc = a->where;
+ if_2->block = else_2;
+
+ if_1 = XCNEW (gfc_code);
+ if_1->op = EXEC_IF;
+ if_1->block = if_2;
+ if_1->loc = a->where;
+
+ return if_1;
+}
+
+
+/* Insert code to issue a runtime error if the expressions are not equal. */
+
+static gfc_code *
+runtime_error_ne (gfc_expr *e1, gfc_expr *e2, const char *msg)
+{
+ gfc_expr *cond;
+ gfc_code *if_1, *if_2;
+ gfc_code *c;
+ gfc_actual_arglist *a1, *a2, *a3;
+
+ gcc_assert (e1->where.lb);
+ /* Build the call to runtime_error. */
+ c = XCNEW (gfc_code);
+ c->op = EXEC_CALL;
+ c->loc = e1->where;
+
+ /* Get a null-terminated message string. */
+
+ a1 = gfc_get_actual_arglist ();
+ a1->expr = gfc_get_character_expr (gfc_default_character_kind, &e1->where,
+ msg, strlen(msg)+1);
+ c->ext.actual = a1;
+
+ /* Pass the value of the first expression. */
+ a2 = gfc_get_actual_arglist ();
+ a2->expr = gfc_copy_expr (e1);
+ a1->next = a2;
+
+ /* Pass the value of the second expression. */
+ a3 = gfc_get_actual_arglist ();
+ a3->expr = gfc_copy_expr (e2);
+ a2->next = a3;
+
+ gfc_check_fe_runtime_error (c->ext.actual);
+ gfc_resolve_fe_runtime_error (c);
+
+ if_2 = XCNEW (gfc_code);
+ if_2->op = EXEC_IF;
+ if_2->loc = e1->where;
+ if_2->next = c;
+
+ if_1 = XCNEW (gfc_code);
+ if_1->op = EXEC_IF;
+ if_1->block = if_2;
+ if_1->loc = e1->where;
+
+ cond = build_logical_expr (INTRINSIC_NE, e1, e2);
+ gfc_simplify_expr (cond, 0);
+ if_2->expr1 = cond;
+
+ return if_1;
+}
+
+/* Handle matrix reallocation. Caller is responsible to insert into
+ the code tree.
+
+ For the two-dimensional case, build
+
+ if (allocated(c)) then
+ if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
+ deallocate(c)
+ allocate (c(size(a,1), size(b,2)))
+ end if
+ else
+ allocate (c(size(a,1),size(b,2)))
+ end if
+
+ and for the other cases correspondingly.
+*/
+
+static gfc_code *
+matmul_lhs_realloc (gfc_expr *c, gfc_expr *a, gfc_expr *b,
+ enum matrix_case m_case)
+{
+
+ gfc_expr *allocated, *alloc_expr;
+ gfc_code *if_alloc_1, *if_alloc_2, *if_size_1, *if_size_2;
+ gfc_code *else_alloc;
+ gfc_code *deallocate, *allocate1, *allocate_else;
+ gfc_array_ref *ar;
+ gfc_expr *cond, *ne1, *ne2;
+
+ if (warn_realloc_lhs)
+ gfc_warning (OPT_Wrealloc_lhs,
+ "Code for reallocating the allocatable array at %L will "
+ "be added", &c->where);
+
+ alloc_expr = gfc_copy_expr (c);
+
+ ar = gfc_find_array_ref (alloc_expr);
+ gcc_assert (ar && ar->type == AR_FULL);
+
+ /* c comes in as a full ref. Change it into a copy and make it into an
+ element ref so it has the right form for ALLOCATE. In the same
+ switch statement, also generate the size comparison for the secod IF
+ statement. */
+
+ ar->type = AR_ELEMENT;
+
+ switch (m_case)
+ {
+ case A2B2:
+ ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
+ ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
+ ne1 = build_logical_expr (INTRINSIC_NE,
+ get_array_inq_function (GFC_ISYM_SIZE, c, 1),
+ get_array_inq_function (GFC_ISYM_SIZE, a, 1));
+ ne2 = build_logical_expr (INTRINSIC_NE,
+ get_array_inq_function (GFC_ISYM_SIZE, c, 2),
+ get_array_inq_function (GFC_ISYM_SIZE, b, 2));
+ cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
+ break;
+
+ case A2B2T:
+ ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
+ ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1);
+
+ ne1 = build_logical_expr (INTRINSIC_NE,
+ get_array_inq_function (GFC_ISYM_SIZE, c, 1),
+ get_array_inq_function (GFC_ISYM_SIZE, a, 1));
+ ne2 = build_logical_expr (INTRINSIC_NE,
+ get_array_inq_function (GFC_ISYM_SIZE, c, 2),
+ get_array_inq_function (GFC_ISYM_SIZE, b, 1));
+ cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
+ break;
+
+ case A2TB2:
+
+ ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
+ ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
+
+ ne1 = build_logical_expr (INTRINSIC_NE,
+ get_array_inq_function (GFC_ISYM_SIZE, c, 1),
+ get_array_inq_function (GFC_ISYM_SIZE, a, 2));
+ ne2 = build_logical_expr (INTRINSIC_NE,
+ get_array_inq_function (GFC_ISYM_SIZE, c, 2),
+ get_array_inq_function (GFC_ISYM_SIZE, b, 2));
+ cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
+ break;
+
+ case A2B1:
+ ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
+ cond = build_logical_expr (INTRINSIC_NE,
+ get_array_inq_function (GFC_ISYM_SIZE, c, 1),
+ get_array_inq_function (GFC_ISYM_SIZE, a, 2));
+ break;
+
+ case A1B2:
+ ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
+ cond = build_logical_expr (INTRINSIC_NE,
+ get_array_inq_function (GFC_ISYM_SIZE, c, 1),
+ get_array_inq_function (GFC_ISYM_SIZE, b, 2));
+ break;
+
+ case A2TB2T:
+ /* This can only happen for BLAS, we do not handle that case in
+ inline mamtul. */
+ ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
+ ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1);
+
+ ne1 = build_logical_expr (INTRINSIC_NE,
+ get_array_inq_function (GFC_ISYM_SIZE, c, 1),
+ get_array_inq_function (GFC_ISYM_SIZE, a, 2));
+ ne2 = build_logical_expr (INTRINSIC_NE,
+ get_array_inq_function (GFC_ISYM_SIZE, c, 2),
+ get_array_inq_function (GFC_ISYM_SIZE, b, 1));
+
+ cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
+ break;
+
+ default:
+ gcc_unreachable();
+
+ }
+
+ gfc_simplify_expr (cond, 0);
+
+ /* We need two identical allocate statements in two
+ branches of the IF statement. */
+
+ allocate1 = XCNEW (gfc_code);
+ allocate1->op = EXEC_ALLOCATE;
+ allocate1->ext.alloc.list = gfc_get_alloc ();
+ allocate1->loc = c->where;
+ allocate1->ext.alloc.list->expr = gfc_copy_expr (alloc_expr);
+
+ allocate_else = XCNEW (gfc_code);
+ allocate_else->op = EXEC_ALLOCATE;
+ allocate_else->ext.alloc.list = gfc_get_alloc ();
+ allocate_else->loc = c->where;
+ allocate_else->ext.alloc.list->expr = alloc_expr;
+
+ allocated = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ALLOCATED,
+ "_gfortran_allocated", c->where,
+ 1, gfc_copy_expr (c));
+
+ deallocate = XCNEW (gfc_code);
+ deallocate->op = EXEC_DEALLOCATE;
+ deallocate->ext.alloc.list = gfc_get_alloc ();
+ deallocate->ext.alloc.list->expr = gfc_copy_expr (c);
+ deallocate->next = allocate1;
+ deallocate->loc = c->where;
+
+ if_size_2 = XCNEW (gfc_code);
+ if_size_2->op = EXEC_IF;
+ if_size_2->expr1 = cond;
+ if_size_2->loc = c->where;
+ if_size_2->next = deallocate;
+
+ if_size_1 = XCNEW (gfc_code);
+ if_size_1->op = EXEC_IF;
+ if_size_1->block = if_size_2;
+ if_size_1->loc = c->where;
+
+ else_alloc = XCNEW (gfc_code);
+ else_alloc->op = EXEC_IF;
+ else_alloc->loc = c->where;
+ else_alloc->next = allocate_else;
+
+ if_alloc_2 = XCNEW (gfc_code);
+ if_alloc_2->op = EXEC_IF;
+ if_alloc_2->expr1 = allocated;
+ if_alloc_2->loc = c->where;
+ if_alloc_2->next = if_size_1;
+ if_alloc_2->block = else_alloc;
+
+ if_alloc_1 = XCNEW (gfc_code);
+ if_alloc_1->op = EXEC_IF;
+ if_alloc_1->block = if_alloc_2;
+ if_alloc_1->loc = c->where;
+
+ return if_alloc_1;
+}
+
+/* Callback function for has_function_or_op. */
+
+static int
+is_function_or_op (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ if ((*e) == 0)
+ return 0;
+ else
+ return (*e)->expr_type == EXPR_FUNCTION
+ || (*e)->expr_type == EXPR_OP;
+}
+
+/* Returns true if the expression contains a function. */
+
+static bool
+has_function_or_op (gfc_expr **e)
+{
+ if (e == NULL)
+ return false;
+ else
+ return gfc_expr_walker (e, is_function_or_op, NULL);
+}
+
+/* Freeze (assign to a temporary variable) a single expression. */
+
+static void
+freeze_expr (gfc_expr **ep)
+{
+ gfc_expr *ne;
+ if (has_function_or_op (ep))
+ {
+ ne = create_var (*ep, "freeze");
+ *ep = ne;
+ }
+}
+
+/* Go through an expression's references and assign them to temporary
+ variables if they contain functions. This is usually done prior to
+ front-end scalarization to avoid multiple invocations of functions. */
+
+static void
+freeze_references (gfc_expr *e)
+{
+ gfc_ref *r;
+ gfc_array_ref *ar;
+ int i;
+
+ for (r=e->ref; r; r=r->next)
+ {
+ if (r->type == REF_SUBSTRING)
+ {
+ if (r->u.ss.start != NULL)
+ freeze_expr (&r->u.ss.start);
+
+ if (r->u.ss.end != NULL)
+ freeze_expr (&r->u.ss.end);
+ }
+ else if (r->type == REF_ARRAY)
+ {
+ ar = &r->u.ar;
+ switch (ar->type)
+ {
+ case AR_FULL:
+ break;
+
+ case AR_SECTION:
+ for (i=0; i<ar->dimen; i++)
+ {
+ if (ar->dimen_type[i] == DIMEN_RANGE)
+ {
+ freeze_expr (&ar->start[i]);
+ freeze_expr (&ar->end[i]);
+ freeze_expr (&ar->stride[i]);
+ }
+ else if (ar->dimen_type[i] == DIMEN_ELEMENT)
+ {
+ freeze_expr (&ar->start[i]);
+ }
+ }
+ break;
+
+ case AR_ELEMENT:
+ for (i=0; i<ar->dimen; i++)
+ freeze_expr (&ar->start[i]);
+ break;
+
+ default:
+ break;
+ }
+ }
+ }
+}
+
+/* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
+
+static gfc_expr *
+convert_to_index_kind (gfc_expr *e)
+{
+ gfc_expr *res;
+
+ gcc_assert (e != NULL);
+
+ res = gfc_copy_expr (e);
+
+ gcc_assert (e->ts.type == BT_INTEGER);
+
+ if (res->ts.kind != gfc_index_integer_kind)
+ {
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_index_integer_kind;
+
+ gfc_convert_type_warn (e, &ts, 2, 0);
+ }
+
+ return res;
+}
+
+/* Function to create a DO loop including creation of the
+ iteration variable. gfc_expr are copied.*/
+
+static gfc_code *
+create_do_loop (gfc_expr *start, gfc_expr *end, gfc_expr *step, locus *where,
+ gfc_namespace *ns, char *vname)
+{
+
+ char name[GFC_MAX_SYMBOL_LEN +1];
+ gfc_symtree *symtree;
+ gfc_symbol *symbol;
+ gfc_expr *i;
+ gfc_code *n, *n2;
+
+ /* Create an expression for the iteration variable. */
+ if (vname)
+ sprintf (name, "__var_%d_do_%s", var_num++, vname);
+ else
+ sprintf (name, "__var_%d_do", var_num++);
+
+
+ if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
+ gcc_unreachable ();
+
+ /* Create the loop variable. */
+
+ symbol = symtree->n.sym;
+ symbol->ts.type = BT_INTEGER;
+ symbol->ts.kind = gfc_index_integer_kind;
+ symbol->attr.flavor = FL_VARIABLE;
+ symbol->attr.referenced = 1;
+ symbol->attr.dimension = 0;
+ symbol->attr.fe_temp = 1;
+ gfc_commit_symbol (symbol);
+
+ i = gfc_get_expr ();
+ i->expr_type = EXPR_VARIABLE;
+ i->ts = symbol->ts;
+ i->rank = 0;
+ i->where = *where;
+ i->symtree = symtree;
+
+ /* ... and the nested DO statements. */
+ n = XCNEW (gfc_code);
+ n->op = EXEC_DO;
+ n->loc = *where;
+ n->ext.iterator = gfc_get_iterator ();
+ n->ext.iterator->var = i;
+ n->ext.iterator->start = convert_to_index_kind (start);
+ n->ext.iterator->end = convert_to_index_kind (end);
+ if (step)
+ n->ext.iterator->step = convert_to_index_kind (step);
+ else
+ n->ext.iterator->step = gfc_get_int_expr (gfc_index_integer_kind,
+ where, 1);
+
+ n2 = XCNEW (gfc_code);
+ n2->op = EXEC_DO;
+ n2->loc = *where;
+ n2->next = NULL;
+ n->block = n2;
+ return n;
+}
+
+/* Get the upper bound of the DO loops for matmul along a dimension. This
+ is one-based. */
+
+static gfc_expr*
+get_size_m1 (gfc_expr *e, int dimen)
+{
+ mpz_t size;
+ gfc_expr *res;
+
+ if (gfc_array_dimen_size (e, dimen - 1, &size))
+ {
+ res = gfc_get_constant_expr (BT_INTEGER,
+ gfc_index_integer_kind, &e->where);
+ mpz_sub_ui (res->value.integer, size, 1);
+ mpz_clear (size);
+ }
+ else
+ {
+ res = get_operand (INTRINSIC_MINUS,
+ get_array_inq_function (GFC_ISYM_SIZE, e, dimen),
+ gfc_get_int_expr (gfc_index_integer_kind,
+ &e->where, 1));
+ gfc_simplify_expr (res, 0);
+ }
+
+ return res;
+}
+
+/* Function to return a scalarized expression. It is assumed that indices are
+ zero based to make generation of DO loops easier. A zero as index will
+ access the first element along a dimension. Single element references will
+ be skipped. A NULL as an expression will be replaced by a full reference.
+ This assumes that the index loops have gfc_index_integer_kind, and that all
+ references have been frozen. */
+
+static gfc_expr*
+scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index)
+{
+ gfc_array_ref *ar;
+ int i;
+ int rank;
+ gfc_expr *e;
+ int i_index;
+ bool was_fullref;
+
+ e = gfc_copy_expr(e_in);
+
+ rank = e->rank;
+
+ ar = gfc_find_array_ref (e);
+
+ /* We scalarize count_index variables, reducing the rank by count_index. */
+
+ e->rank = rank - count_index;
+
+ was_fullref = ar->type == AR_FULL;
+
+ if (e->rank == 0)
+ ar->type = AR_ELEMENT;
+ else
+ ar->type = AR_SECTION;
+
+ /* Loop over the indices. For each index, create the expression
+ index * stride + lbound(e, dim). */
+
+ i_index = 0;
+ for (i=0; i < ar->dimen; i++)
+ {
+ if (was_fullref || ar->dimen_type[i] == DIMEN_RANGE)
+ {
+ if (index[i_index] != NULL)
+ {
+ gfc_expr *lbound, *nindex;
+ gfc_expr *loopvar;
+
+ loopvar = gfc_copy_expr (index[i_index]);
+
+ if (ar->stride[i])
+ {
+ gfc_expr *tmp;
+
+ tmp = gfc_copy_expr(ar->stride[i]);
+ if (tmp->ts.kind != gfc_index_integer_kind)
+ {
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_index_integer_kind;
+ gfc_convert_type (tmp, &ts, 2);
+ }
+ nindex = get_operand (INTRINSIC_TIMES, loopvar, tmp);
+ }
+ else
+ nindex = loopvar;
+
+ /* Calculate the lower bound of the expression. */
+ if (ar->start[i])
+ {
+ lbound = gfc_copy_expr (ar->start[i]);
+ if (lbound->ts.kind != gfc_index_integer_kind)
+ {
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_index_integer_kind;
+ gfc_convert_type (lbound, &ts, 2);
+
+ }
+ }
+ else
+ {
+ gfc_expr *lbound_e;
+ gfc_ref *ref;
+
+ lbound_e = gfc_copy_expr (e_in);
+
+ for (ref = lbound_e->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY
+ && (ref->u.ar.type == AR_FULL
+ || ref->u.ar.type == AR_SECTION))
+ break;
+
+ if (ref->next)
+ {
+ gfc_free_ref_list (ref->next);
+ ref->next = NULL;
+ }
+
+ if (!was_fullref)
+ {
+ /* Look at full individual sections, like a(:). The first index
+ is the lbound of a full ref. */
+ int j;
+ gfc_array_ref *ar;
+ int to;
+
+ ar = &ref->u.ar;
+
+ /* For assumed size, we need to keep around the final
+ reference in order not to get an error on resolution
+ below, and we cannot use AR_FULL. */
+
+ if (ar->as->type == AS_ASSUMED_SIZE)
+ {
+ ar->type = AR_SECTION;
+ to = ar->dimen - 1;
+ }
+ else
+ {
+ to = ar->dimen;
+ ar->type = AR_FULL;
+ }
+
+ for (j = 0; j < to; j++)
+ {
+ gfc_free_expr (ar->start[j]);
+ ar->start[j] = NULL;
+ gfc_free_expr (ar->end[j]);
+ ar->end[j] = NULL;
+ gfc_free_expr (ar->stride[j]);
+ ar->stride[j] = NULL;
+ }
+
+ /* We have to get rid of the shape, if there is one. Do
+ so by freeing it and calling gfc_resolve to rebuild
+ it, if necessary. */
+
+ if (lbound_e->shape)
+ gfc_free_shape (&(lbound_e->shape), lbound_e->rank);
+
+ lbound_e->rank = ar->dimen;
+ gfc_resolve_expr (lbound_e);
+ }
+ lbound = get_array_inq_function (GFC_ISYM_LBOUND, lbound_e,
+ i + 1);
+ gfc_free_expr (lbound_e);
+ }
+
+ ar->dimen_type[i] = DIMEN_ELEMENT;
+
+ gfc_free_expr (ar->start[i]);
+ ar->start[i] = get_operand (INTRINSIC_PLUS, nindex, lbound);
+
+ gfc_free_expr (ar->end[i]);
+ ar->end[i] = NULL;
+ gfc_free_expr (ar->stride[i]);
+ ar->stride[i] = NULL;
+ gfc_simplify_expr (ar->start[i], 0);
+ }
+ else if (was_fullref)
+ {
+ gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
+ }
+ i_index ++;
+ }
+ }
+
+ /* Bounds checking will be done before the loops if -fcheck=bounds
+ is in effect. */
+ e->no_bounds_check = 1;
+ return e;
+}
+
+/* Helper function to check for a dimen vector as subscript. */
+
+bool
+gfc_has_dimen_vector_ref (gfc_expr *e)
+{
+ gfc_array_ref *ar;
+ int i;
+
+ ar = gfc_find_array_ref (e);
+ gcc_assert (ar);
+ if (ar->type == AR_FULL)
+ return false;
+
+ for (i=0; i<ar->dimen; i++)
+ if (ar->dimen_type[i] == DIMEN_VECTOR)
+ return true;
+
+ return false;
+}
+
+/* If handed an expression of the form
+
+ TRANSPOSE(CONJG(A))
+
+ check if A can be handled by matmul and return if there is an uneven number
+ of CONJG calls. Return a pointer to the array when everything is OK, NULL
+ otherwise. The caller has to check for the correct rank. */
+
+static gfc_expr*
+check_conjg_transpose_variable (gfc_expr *e, bool *conjg, bool *transpose)
+{
+ *conjg = false;
+ *transpose = false;
+
+ do
+ {
+ if (e->expr_type == EXPR_VARIABLE)
+ {
+ gcc_assert (e->rank == 1 || e->rank == 2);
+ return e;
+ }
+ else if (e->expr_type == EXPR_FUNCTION)
+ {
+ if (e->value.function.isym == NULL)
+ return NULL;
+
+ if (e->value.function.isym->id == GFC_ISYM_CONJG)
+ *conjg = !*conjg;
+ else if (e->value.function.isym->id == GFC_ISYM_TRANSPOSE)
+ *transpose = !*transpose;
+ else return NULL;
+ }
+ else
+ return NULL;
+
+ e = e->value.function.actual->expr;
+ }
+ while(1);
+
+ return NULL;
+}
+
+/* Macros for unified error messages. */
+
+#define B_ERROR_1 _("Incorrect extent in argument B in MATMUL intrinsic in " \
+ "dimension 1: is %ld, should be %ld")
+
+#define C_ERROR_1 _("Array bound mismatch for dimension 1 of array " \
+ "(%ld/%ld)")
+
+#define C_ERROR_2 _("Array bound mismatch for dimension 2 of array " \
+ "(%ld/%ld)")
+
+
+/* Inline assignments of the form c = matmul(a,b).
+ Handle only the cases currently where b and c are rank-two arrays.
+
+ This basically translates the code to
+
+ BLOCK
+ integer i,j,k
+ c = 0
+ do j=0, size(b,2)-1
+ do k=0, size(a, 2)-1
+ do i=0, size(a, 1)-1
+ c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
+ c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
+ a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
+ b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
+ end do
+ end do
+ end do
+ END BLOCK
+
+*/
+
+static int
+inline_matmul_assign (gfc_code **c, int *walk_subtrees,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_code *co = *c;
+ gfc_expr *expr1, *expr2;
+ gfc_expr *matrix_a, *matrix_b;
+ gfc_actual_arglist *a, *b;
+ gfc_code *do_1, *do_2, *do_3, *assign_zero, *assign_matmul;
+ gfc_expr *zero_e;
+ gfc_expr *u1, *u2, *u3;
+ gfc_expr *list[2];
+ gfc_expr *ascalar, *bscalar, *cscalar;
+ gfc_expr *mult;
+ gfc_expr *var_1, *var_2, *var_3;
+ gfc_expr *zero;
+ gfc_namespace *ns;
+ gfc_intrinsic_op op_times, op_plus;
+ enum matrix_case m_case;
+ int i;
+ gfc_code *if_limit = NULL;
+ gfc_code **next_code_point;
+ bool conjg_a, conjg_b, transpose_a, transpose_b;
+ bool realloc_c;
+
+ if (co->op != EXEC_ASSIGN)
+ return 0;
+
+ if (in_where || in_assoc_list)
+ return 0;
+
+ /* The BLOCKS generated for the temporary variables and FORALL don't
+ mix. */
+ if (forall_level > 0)
+ return 0;
+
+ /* For now don't do anything in OpenMP workshare, it confuses
+ its translation, which expects only the allowed statements in there.
+ We should figure out how to parallelize this eventually. */
+ if (in_omp_workshare || in_omp_atomic)
+ return 0;
+
+ expr1 = co->expr1;
+ expr2 = co->expr2;
+ if (expr2->expr_type != EXPR_FUNCTION
+ || expr2->value.function.isym == NULL
+ || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
+ return 0;
+
+ current_code = c;
+ inserted_block = NULL;
+ changed_statement = NULL;
+
+ a = expr2->value.function.actual;
+ matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
+ if (matrix_a == NULL)
+ return 0;
+
+ b = a->next;
+ matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
+ if (matrix_b == NULL)
+ return 0;
+
+ if (gfc_has_dimen_vector_ref (expr1) || gfc_has_dimen_vector_ref (matrix_a)
+ || gfc_has_dimen_vector_ref (matrix_b))
+ return 0;
+
+ /* We do not handle data dependencies yet. */
+ if (gfc_check_dependency (expr1, matrix_a, true)
+ || gfc_check_dependency (expr1, matrix_b, true))
+ return 0;
+
+ m_case = none;
+ if (matrix_a->rank == 2)
+ {
+ if (transpose_a)
+ {
+ if (matrix_b->rank == 2 && !transpose_b)
+ m_case = A2TB2;
+ }
+ else
+ {
+ if (matrix_b->rank == 1)
+ m_case = A2B1;
+ else /* matrix_b->rank == 2 */
+ {
+ if (transpose_b)
+ m_case = A2B2T;
+ else
+ m_case = A2B2;
+ }
+ }
+ }
+ else /* matrix_a->rank == 1 */
+ {
+ if (matrix_b->rank == 2)
+ {
+ if (!transpose_b)
+ m_case = A1B2;
+ }
+ }
+
+ if (m_case == none)
+ return 0;
+
+ /* We only handle assignment to numeric or logical variables. */
+ switch(expr1->ts.type)
+ {
+ case BT_INTEGER:
+ case BT_LOGICAL:
+ case BT_REAL:
+ case BT_COMPLEX:
+ break;
+
+ default:
+ return 0;
+ }
+
+ ns = insert_block ();
+
+ /* Assign the type of the zero expression for initializing the resulting
+ array, and the expression (+ and * for real, integer and complex;
+ .and. and .or for logical. */
+
+ switch(expr1->ts.type)
+ {
+ case BT_INTEGER:
+ zero_e = gfc_get_int_expr (expr1->ts.kind, &expr1->where, 0);
+ op_times = INTRINSIC_TIMES;
+ op_plus = INTRINSIC_PLUS;
+ break;
+
+ case BT_LOGICAL:
+ op_times = INTRINSIC_AND;
+ op_plus = INTRINSIC_OR;
+ zero_e = gfc_get_logical_expr (expr1->ts.kind, &expr1->where,
+ 0);
+ break;
+ case BT_REAL:
+ zero_e = gfc_get_constant_expr (BT_REAL, expr1->ts.kind,
+ &expr1->where);
+ mpfr_set_si (zero_e->value.real, 0, GFC_RND_MODE);
+ op_times = INTRINSIC_TIMES;
+ op_plus = INTRINSIC_PLUS;
+ break;
+
+ case BT_COMPLEX:
+ zero_e = gfc_get_constant_expr (BT_COMPLEX, expr1->ts.kind,
+ &expr1->where);
+ mpc_set_si_si (zero_e->value.complex, 0, 0, GFC_RND_MODE);
+ op_times = INTRINSIC_TIMES;
+ op_plus = INTRINSIC_PLUS;
+
+ break;
+
+ default:
+ gcc_unreachable();
+ }
+
+ current_code = &ns->code;
+
+ /* Freeze the references, keeping track of how many temporary variables were
+ created. */
+ n_vars = 0;
+ freeze_references (matrix_a);
+ freeze_references (matrix_b);
+ freeze_references (expr1);
+
+ if (n_vars == 0)
+ next_code_point = current_code;
+ else
+ {
+ next_code_point = &ns->code;
+ for (i=0; i<n_vars; i++)
+ next_code_point = &(*next_code_point)->next;
+ }
+
+ /* Take care of the inline flag. If the limit check evaluates to a
+ constant, dead code elimination will eliminate the unneeded branch. */
+
+ if (flag_inline_matmul_limit > 0
+ && (matrix_a->rank == 1 || matrix_a->rank == 2)
+ && matrix_b->rank == 2)
+ {
+ if_limit = inline_limit_check (matrix_a, matrix_b,
+ flag_inline_matmul_limit,
+ matrix_a->rank);
+
+ /* Insert the original statement into the else branch. */
+ if_limit->block->block->next = co;
+ co->next = NULL;
+
+ /* ... and the new ones go into the original one. */
+ *next_code_point = if_limit;
+ next_code_point = &if_limit->block->next;
+ }
+
+ zero_e->no_bounds_check = 1;
+
+ assign_zero = XCNEW (gfc_code);
+ assign_zero->op = EXEC_ASSIGN;
+ assign_zero->loc = co->loc;
+ assign_zero->expr1 = gfc_copy_expr (expr1);
+ assign_zero->expr1->no_bounds_check = 1;
+ assign_zero->expr2 = zero_e;
+
+ realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1);
+
+ if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+ {
+ gfc_code *test;
+ gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
+
+ switch (m_case)
+ {
+ case A2B1:
+
+ b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
+ a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
+ test = runtime_error_ne (b1, a2, B_ERROR_1);
+ *next_code_point = test;
+ next_code_point = &test->next;
+
+ if (!realloc_c)
+ {
+ c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
+ a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
+ test = runtime_error_ne (c1, a1, C_ERROR_1);
+ *next_code_point = test;
+ next_code_point = &test->next;
+ }
+ break;
+
+ case A1B2:
+
+ b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
+ a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
+ test = runtime_error_ne (b1, a1, B_ERROR_1);
+ *next_code_point = test;
+ next_code_point = &test->next;
+
+ if (!realloc_c)
+ {
+ c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
+ b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
+ test = runtime_error_ne (c1, b2, C_ERROR_1);
+ *next_code_point = test;
+ next_code_point = &test->next;
+ }
+ break;
+
+ case A2B2:
+
+ b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
+ a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
+ test = runtime_error_ne (b1, a2, B_ERROR_1);
+ *next_code_point = test;
+ next_code_point = &test->next;
+
+ if (!realloc_c)
+ {
+ c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
+ a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
+ test = runtime_error_ne (c1, a1, C_ERROR_1);
+ *next_code_point = test;
+ next_code_point = &test->next;
+
+ c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
+ b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
+ test = runtime_error_ne (c2, b2, C_ERROR_2);
+ *next_code_point = test;
+ next_code_point = &test->next;
+ }
+ break;
+
+ case A2B2T:
+
+ b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
+ a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
+ /* matrix_b is transposed, hence dimension 1 for the error message. */
+ test = runtime_error_ne (b2, a2, B_ERROR_1);
+ *next_code_point = test;
+ next_code_point = &test->next;
+
+ if (!realloc_c)
+ {
+ c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
+ a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
+ test = runtime_error_ne (c1, a1, C_ERROR_1);
+ *next_code_point = test;
+ next_code_point = &test->next;
+
+ c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
+ b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
+ test = runtime_error_ne (c2, b1, C_ERROR_2);
+ *next_code_point = test;
+ next_code_point = &test->next;
+ }
+ break;
+
+ case A2TB2:
+
+ b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
+ a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
+ test = runtime_error_ne (b1, a1, B_ERROR_1);
+ *next_code_point = test;
+ next_code_point = &test->next;
+
+ if (!realloc_c)
+ {
+ c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
+ a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
+ test = runtime_error_ne (c1, a2, C_ERROR_1);
+ *next_code_point = test;
+ next_code_point = &test->next;
+
+ c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
+ b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
+ test = runtime_error_ne (c2, b2, C_ERROR_2);
+ *next_code_point = test;
+ next_code_point = &test->next;
+ }
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+ }
+
+ /* Handle the reallocation, if needed. */
+
+ if (realloc_c)
+ {
+ gfc_code *lhs_alloc;
+
+ lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case);
+
+ *next_code_point = lhs_alloc;
+ next_code_point = &lhs_alloc->next;
+
+ }
+
+ *next_code_point = assign_zero;
+
+ zero = gfc_get_int_expr (gfc_index_integer_kind, &co->loc, 0);
+
+ assign_matmul = XCNEW (gfc_code);
+ assign_matmul->op = EXEC_ASSIGN;
+ assign_matmul->loc = co->loc;
+
+ /* Get the bounds for the loops, create them and create the scalarized
+ expressions. */
+
+ switch (m_case)
+ {
+ case A2B2:
+
+ u1 = get_size_m1 (matrix_b, 2);
+ u2 = get_size_m1 (matrix_a, 2);
+ u3 = get_size_m1 (matrix_a, 1);
+
+ do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
+ do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
+ do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
+
+ do_1->block->next = do_2;
+ do_2->block->next = do_3;
+ do_3->block->next = assign_matmul;
+
+ var_1 = do_1->ext.iterator->var;
+ var_2 = do_2->ext.iterator->var;
+ var_3 = do_3->ext.iterator->var;
+
+ list[0] = var_3;
+ list[1] = var_1;
+ cscalar = scalarized_expr (co->expr1, list, 2);
+
+ list[0] = var_3;
+ list[1] = var_2;
+ ascalar = scalarized_expr (matrix_a, list, 2);
+
+ list[0] = var_2;
+ list[1] = var_1;
+ bscalar = scalarized_expr (matrix_b, list, 2);
+
+ break;
+
+ case A2B2T:
+
+ u1 = get_size_m1 (matrix_b, 1);
+ u2 = get_size_m1 (matrix_a, 2);
+ u3 = get_size_m1 (matrix_a, 1);
+
+ do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
+ do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
+ do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
+
+ do_1->block->next = do_2;
+ do_2->block->next = do_3;
+ do_3->block->next = assign_matmul;
+
+ var_1 = do_1->ext.iterator->var;
+ var_2 = do_2->ext.iterator->var;
+ var_3 = do_3->ext.iterator->var;
+
+ list[0] = var_3;
+ list[1] = var_1;
+ cscalar = scalarized_expr (co->expr1, list, 2);
+
+ list[0] = var_3;
+ list[1] = var_2;
+ ascalar = scalarized_expr (matrix_a, list, 2);
+
+ list[0] = var_1;
+ list[1] = var_2;
+ bscalar = scalarized_expr (matrix_b, list, 2);
+
+ break;
+
+ case A2TB2:
+
+ u1 = get_size_m1 (matrix_a, 2);
+ u2 = get_size_m1 (matrix_b, 2);
+ u3 = get_size_m1 (matrix_a, 1);
+
+ do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
+ do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
+ do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
+
+ do_1->block->next = do_2;
+ do_2->block->next = do_3;
+ do_3->block->next = assign_matmul;
+
+ var_1 = do_1->ext.iterator->var;
+ var_2 = do_2->ext.iterator->var;
+ var_3 = do_3->ext.iterator->var;
+
+ list[0] = var_1;
+ list[1] = var_2;
+ cscalar = scalarized_expr (co->expr1, list, 2);
+
+ list[0] = var_3;
+ list[1] = var_1;
+ ascalar = scalarized_expr (matrix_a, list, 2);
+
+ list[0] = var_3;
+ list[1] = var_2;
+ bscalar = scalarized_expr (matrix_b, list, 2);
+
+ break;
+
+ case A2B1:
+ u1 = get_size_m1 (matrix_b, 1);
+ u2 = get_size_m1 (matrix_a, 1);
+
+ do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
+ do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
+
+ do_1->block->next = do_2;
+ do_2->block->next = assign_matmul;
+
+ var_1 = do_1->ext.iterator->var;
+ var_2 = do_2->ext.iterator->var;
+
+ list[0] = var_2;
+ cscalar = scalarized_expr (co->expr1, list, 1);
+
+ list[0] = var_2;
+ list[1] = var_1;
+ ascalar = scalarized_expr (matrix_a, list, 2);
+
+ list[0] = var_1;
+ bscalar = scalarized_expr (matrix_b, list, 1);
+
+ break;
+
+ case A1B2:
+ u1 = get_size_m1 (matrix_b, 2);
+ u2 = get_size_m1 (matrix_a, 1);
+
+ do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
+ do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
+
+ do_1->block->next = do_2;
+ do_2->block->next = assign_matmul;
+
+ var_1 = do_1->ext.iterator->var;
+ var_2 = do_2->ext.iterator->var;
+
+ list[0] = var_1;
+ cscalar = scalarized_expr (co->expr1, list, 1);
+
+ list[0] = var_2;
+ ascalar = scalarized_expr (matrix_a, list, 1);
+
+ list[0] = var_2;
+ list[1] = var_1;
+ bscalar = scalarized_expr (matrix_b, list, 2);
+
+ break;
+
+ default:
+ gcc_unreachable();
+ }
+
+ /* Build the conjg call around the variables. Set the typespec manually
+ because gfc_build_intrinsic_call sometimes gets this wrong. */
+ if (conjg_a)
+ {
+ gfc_typespec ts;
+ ts = matrix_a->ts;
+ ascalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg",
+ matrix_a->where, 1, ascalar);
+ ascalar->ts = ts;
+ }
+
+ if (conjg_b)
+ {
+ gfc_typespec ts;
+ ts = matrix_b->ts;
+ bscalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg",
+ matrix_b->where, 1, bscalar);
+ bscalar->ts = ts;
+ }
+ /* First loop comes after the zero assignment. */
+ assign_zero->next = do_1;
+
+ /* Build the assignment expression in the loop. */
+ assign_matmul->expr1 = gfc_copy_expr (cscalar);
+
+ mult = get_operand (op_times, ascalar, bscalar);
+ assign_matmul->expr2 = get_operand (op_plus, cscalar, mult);
+
+ /* If we don't want to keep the original statement around in
+ the else branch, we can free it. */
+
+ if (if_limit == NULL)
+ gfc_free_statements(co);
+ else
+ co->next = NULL;
+
+ gfc_free_expr (zero);
+ *walk_subtrees = 0;
+ return 0;
+}
+
+/* Change matmul function calls in the form of
+
+ c = matmul(a,b)
+
+ to the corresponding call to a BLAS routine, if applicable. */
+
+static int
+call_external_blas (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_code *co, *co_next;
+ gfc_expr *expr1, *expr2;
+ gfc_expr *matrix_a, *matrix_b;
+ gfc_code *if_limit = NULL;
+ gfc_actual_arglist *a, *b;
+ bool conjg_a, conjg_b, transpose_a, transpose_b;
+ gfc_code *call;
+ const char *blas_name;
+ const char *transa, *transb;
+ gfc_expr *c1, *c2, *b1;
+ gfc_actual_arglist *actual, *next;
+ bt type;
+ int kind;
+ enum matrix_case m_case;
+ bool realloc_c;
+ gfc_code **next_code_point;
+
+ /* Many of the tests for inline matmul also apply here. */
+
+ co = *c;
+
+ if (co->op != EXEC_ASSIGN)
+ return 0;
+
+ if (in_where || in_assoc_list)
+ return 0;
+
+ /* The BLOCKS generated for the temporary variables and FORALL don't
+ mix. */
+ if (forall_level > 0)
+ return 0;
+
+ /* For now don't do anything in OpenMP workshare, it confuses
+ its translation, which expects only the allowed statements in there. */
+
+ if (in_omp_workshare || in_omp_atomic)
+ return 0;
+
+ expr1 = co->expr1;
+ expr2 = co->expr2;
+ if (expr2->expr_type != EXPR_FUNCTION
+ || expr2->value.function.isym == NULL
+ || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
+ return 0;
+
+ type = expr2->ts.type;
+ kind = expr2->ts.kind;
+
+ /* Guard against recursion. */
+
+ if (expr2->external_blas)
+ return 0;
+
+ if (type != expr1->ts.type || kind != expr1->ts.kind)
+ return 0;
+
+ if (type == BT_REAL)
+ {
+ if (kind == 4)
+ blas_name = "sgemm";
+ else if (kind == 8)
+ blas_name = "dgemm";
+ else
+ return 0;
+ }
+ else if (type == BT_COMPLEX)
+ {
+ if (kind == 4)
+ blas_name = "cgemm";
+ else if (kind == 8)
+ blas_name = "zgemm";
+ else
+ return 0;
+ }
+ else
+ return 0;
+
+ a = expr2->value.function.actual;
+ if (a->expr->rank != 2)
+ return 0;
+
+ b = a->next;
+ if (b->expr->rank != 2)
+ return 0;
+
+ matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
+ if (matrix_a == NULL)
+ return 0;
+
+ if (transpose_a)
+ {
+ if (conjg_a)
+ transa = "C";
+ else
+ transa = "T";
+ }
+ else
+ transa = "N";
+
+ matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
+ if (matrix_b == NULL)
+ return 0;
+
+ if (transpose_b)
+ {
+ if (conjg_b)
+ transb = "C";
+ else
+ transb = "T";
+ }
+ else
+ transb = "N";
+
+ if (transpose_a)
+ {
+ if (transpose_b)
+ m_case = A2TB2T;
+ else
+ m_case = A2TB2;
+ }
+ else
+ {
+ if (transpose_b)
+ m_case = A2B2T;
+ else
+ m_case = A2B2;
+ }
+
+ current_code = c;
+ inserted_block = NULL;
+ changed_statement = NULL;
+
+ expr2->external_blas = 1;
+
+ /* We do not handle data dependencies yet. */
+ if (gfc_check_dependency (expr1, matrix_a, true)
+ || gfc_check_dependency (expr1, matrix_b, true))
+ return 0;
+
+ /* Generate the if statement and hang it into the tree. */
+ if_limit = inline_limit_check (matrix_a, matrix_b, flag_blas_matmul_limit, 2);
+ co_next = co->next;
+ (*current_code) = if_limit;
+ co->next = NULL;
+ if_limit->block->next = co;
+
+ call = XCNEW (gfc_code);
+ call->loc = co->loc;
+
+ /* Bounds checking - a bit simpler than for inlining since we only
+ have to take care of two-dimensional arrays here. */
+
+ realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1);
+ next_code_point = &(if_limit->block->block->next);
+
+ if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+ {
+ gfc_code *test;
+ // gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
+ gfc_expr *c1, *a1, *c2, *b2, *a2;
+ switch (m_case)
+ {
+ case A2B2:
+ b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
+ a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
+ test = runtime_error_ne (b1, a2, B_ERROR_1);
+ *next_code_point = test;
+ next_code_point = &test->next;
+
+ if (!realloc_c)
+ {
+ c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
+ a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
+ test = runtime_error_ne (c1, a1, C_ERROR_1);
+ *next_code_point = test;
+ next_code_point = &test->next;
+
+ c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
+ b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
+ test = runtime_error_ne (c2, b2, C_ERROR_2);
+ *next_code_point = test;
+ next_code_point = &test->next;
+ }
+ break;
+
+ case A2B2T:
+
+ b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
+ a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
+ /* matrix_b is transposed, hence dimension 1 for the error message. */
+ test = runtime_error_ne (b2, a2, B_ERROR_1);
+ *next_code_point = test;
+ next_code_point = &test->next;
+
+ if (!realloc_c)
+ {
+ c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
+ a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
+ test = runtime_error_ne (c1, a1, C_ERROR_1);
+ *next_code_point = test;
+ next_code_point = &test->next;
+
+ c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
+ b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
+ test = runtime_error_ne (c2, b1, C_ERROR_2);
+ *next_code_point = test;
+ next_code_point = &test->next;
+ }
+ break;
+
+ case A2TB2:
+
+ b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
+ a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
+ test = runtime_error_ne (b1, a1, B_ERROR_1);
+ *next_code_point = test;
+ next_code_point = &test->next;
+
+ if (!realloc_c)
+ {
+ c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
+ a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
+ test = runtime_error_ne (c1, a2, C_ERROR_1);
+ *next_code_point = test;
+ next_code_point = &test->next;
+
+ c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
+ b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
+ test = runtime_error_ne (c2, b2, C_ERROR_2);
+ *next_code_point = test;
+ next_code_point = &test->next;
+ }
+ break;
+
+ case A2TB2T:
+ b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
+ a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
+ test = runtime_error_ne (b2, a1, B_ERROR_1);
+ *next_code_point = test;
+ next_code_point = &test->next;
+
+ if (!realloc_c)
+ {
+ c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
+ a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
+ test = runtime_error_ne (c1, a2, C_ERROR_1);
+ *next_code_point = test;
+ next_code_point = &test->next;
+
+ c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
+ b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
+ test = runtime_error_ne (c2, b1, C_ERROR_2);
+ *next_code_point = test;
+ next_code_point = &test->next;
+ }
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+ }
+
+ /* Handle the reallocation, if needed. */
+
+ if (realloc_c)
+ {
+ gfc_code *lhs_alloc;
+
+ lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case);
+ *next_code_point = lhs_alloc;
+ next_code_point = &lhs_alloc->next;
+ }
+
+ *next_code_point = call;
+ if_limit->next = co_next;
+
+ /* Set up the BLAS call. */
+
+ call->op = EXEC_CALL;
+
+ gfc_get_sym_tree (blas_name, current_ns, &(call->symtree), true);
+ call->symtree->n.sym->attr.subroutine = 1;
+ call->symtree->n.sym->attr.procedure = 1;
+ call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+ call->resolved_sym = call->symtree->n.sym;
+ gfc_commit_symbol (call->resolved_sym);
+
+ /* Argument TRANSA. */
+ next = gfc_get_actual_arglist ();
+ next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc,
+ transa, 1);
+
+ call->ext.actual = next;
+
+ /* Argument TRANSB. */
+ actual = next;
+ next = gfc_get_actual_arglist ();
+ next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc,
+ transb, 1);
+ actual->next = next;
+
+ c1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (a->expr), 1,
+ gfc_integer_4_kind);
+ c2 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 2,
+ gfc_integer_4_kind);
+
+ b1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 1,
+ gfc_integer_4_kind);
+
+ /* Argument M. */
+ actual = next;
+ next = gfc_get_actual_arglist ();
+ next->expr = c1;
+ actual->next = next;
+
+ /* Argument N. */
+ actual = next;
+ next = gfc_get_actual_arglist ();
+ next->expr = c2;
+ actual->next = next;
+
+ /* Argument K. */
+ actual = next;
+ next = gfc_get_actual_arglist ();
+ next->expr = b1;
+ actual->next = next;
+
+ /* Argument ALPHA - set to one. */
+ actual = next;
+ next = gfc_get_actual_arglist ();
+ next->expr = gfc_get_constant_expr (type, kind, &co->loc);
+ if (type == BT_REAL)
+ mpfr_set_ui (next->expr->value.real, 1, GFC_RND_MODE);
+ else
+ mpc_set_ui (next->expr->value.complex, 1, GFC_MPC_RND_MODE);
+ actual->next = next;
+
+ /* Argument A. */
+ actual = next;
+ next = gfc_get_actual_arglist ();
+ next->expr = gfc_copy_expr (matrix_a);
+ actual->next = next;
+
+ /* Argument LDA. */
+ actual = next;
+ next = gfc_get_actual_arglist ();
+ next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_a),
+ 1, gfc_integer_4_kind);
+ actual->next = next;
+
+ /* Argument B. */
+ actual = next;
+ next = gfc_get_actual_arglist ();
+ next->expr = gfc_copy_expr (matrix_b);
+ actual->next = next;
+
+ /* Argument LDB. */
+ actual = next;
+ next = gfc_get_actual_arglist ();
+ next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_b),
+ 1, gfc_integer_4_kind);
+ actual->next = next;
+
+ /* Argument BETA - set to zero. */
+ actual = next;
+ next = gfc_get_actual_arglist ();
+ next->expr = gfc_get_constant_expr (type, kind, &co->loc);
+ if (type == BT_REAL)
+ mpfr_set_ui (next->expr->value.real, 0, GFC_RND_MODE);
+ else
+ mpc_set_ui (next->expr->value.complex, 0, GFC_MPC_RND_MODE);
+ actual->next = next;
+
+ /* Argument C. */
+
+ actual = next;
+ next = gfc_get_actual_arglist ();
+ next->expr = gfc_copy_expr (expr1);
+ actual->next = next;
+
+ /* Argument LDC. */
+ actual = next;
+ next = gfc_get_actual_arglist ();
+ next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (expr1),
+ 1, gfc_integer_4_kind);
+ actual->next = next;
+
+ return 0;
+}
+
+
+/* Code for index interchange for loops which are grouped together in DO
+ CONCURRENT or FORALL statements. This is currently only applied if the
+ iterations are grouped together in a single statement.
+
+ For this transformation, it is assumed that memory access in strides is
+ expensive, and that loops which access later indices (which access memory
+ in bigger strides) should be moved to the first loops.
+
+ For this, a loop over all the statements is executed, counting the times
+ that the loop iteration values are accessed in each index. The loop
+ indices are then sorted to minimize access to later indices from inner
+ loops. */
+
+/* Type for holding index information. */
+
+typedef struct {
+ gfc_symbol *sym;
+ gfc_forall_iterator *fa;
+ int num;
+ int n[GFC_MAX_DIMENSIONS];
+} ind_type;
+
+/* Callback function to determine if an expression is the
+ corresponding variable. */
+
+static int
+has_var (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, void *data)
+{
+ gfc_expr *expr = *e;
+ gfc_symbol *sym;
+
+ if (expr->expr_type != EXPR_VARIABLE)
+ return 0;
+
+ sym = (gfc_symbol *) data;
+ return sym == expr->symtree->n.sym;
+}
+
+/* Callback function to calculate the cost of a certain index. */
+
+static int
+index_cost (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data)
+{
+ ind_type *ind;
+ gfc_expr *expr;
+ gfc_array_ref *ar;
+ gfc_ref *ref;
+ int i,j;
+
+ expr = *e;
+ if (expr->expr_type != EXPR_VARIABLE)
+ return 0;
+
+ ar = NULL;
+ for (ref = expr->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_ARRAY)
+ {
+ ar = &ref->u.ar;
+ break;
+ }
+ }
+ if (ar == NULL || ar->type != AR_ELEMENT)
+ return 0;
+
+ ind = (ind_type *) data;
+ for (i = 0; i < ar->dimen; i++)
+ {
+ for (j=0; ind[j].sym != NULL; j++)
+ {
+ if (gfc_expr_walker (&ar->start[i], has_var, (void *) (ind[j].sym)))
+ ind[j].n[i]++;
+ }
+ }
+ return 0;
+}
+
+/* Callback function for qsort, to sort the loop indices. */
+
+static int
+loop_comp (const void *e1, const void *e2)
+{
+ const ind_type *i1 = (const ind_type *) e1;
+ const ind_type *i2 = (const ind_type *) e2;
+ int i;
+
+ for (i=GFC_MAX_DIMENSIONS-1; i >= 0; i--)
+ {
+ if (i1->n[i] != i2->n[i])
+ return i1->n[i] - i2->n[i];
+ }
+ /* All other things being equal, let's not change the ordering. */
+ return i2->num - i1->num;
+}
+
+/* Main function to do the index interchange. */
+
+static int
+index_interchange (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_code *co;
+ co = *c;
+ int n_iter;
+ gfc_forall_iterator *fa;
+ ind_type *ind;
+ int i, j;
+
+ if (co->op != EXEC_FORALL && co->op != EXEC_DO_CONCURRENT)
+ return 0;
+
+ n_iter = 0;
+ for (fa = co->ext.forall_iterator; fa; fa = fa->next)
+ n_iter ++;
+
+ /* Nothing to reorder. */
+ if (n_iter < 2)
+ return 0;
+
+ ind = XALLOCAVEC (ind_type, n_iter + 1);
+
+ i = 0;
+ for (fa = co->ext.forall_iterator; fa; fa = fa->next)
+ {
+ ind[i].sym = fa->var->symtree->n.sym;
+ ind[i].fa = fa;
+ for (j=0; j<GFC_MAX_DIMENSIONS; j++)
+ ind[i].n[j] = 0;
+ ind[i].num = i;
+ i++;
+ }
+ ind[n_iter].sym = NULL;
+ ind[n_iter].fa = NULL;
+
+ gfc_code_walker (c, gfc_dummy_code_callback, index_cost, (void *) ind);
+ qsort ((void *) ind, n_iter, sizeof (ind_type), loop_comp);
+
+ /* Do the actual index interchange. */
+ co->ext.forall_iterator = fa = ind[0].fa;
+ for (i=1; i<n_iter; i++)
+ {
+ fa->next = ind[i].fa;
+ fa = fa->next;
+ }
+ fa->next = NULL;
+
+ if (flag_warn_frontend_loop_interchange)
+ {
+ for (i=1; i<n_iter; i++)
+ {
+ if (ind[i-1].num > ind[i].num)
+ {
+ gfc_warning (OPT_Wfrontend_loop_interchange,
+ "Interchanging loops at %L", &co->loc);
+ break;
+ }
+ }
+ }
+
+ return 0;
+}
+
+#define WALK_SUBEXPR(NODE) \
+ do \
+ { \
+ result = gfc_expr_walker (&(NODE), exprfn, data); \
+ if (result) \
+ return result; \
+ } \
+ while (0)
+#define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
+
+/* Walk expression *E, calling EXPRFN on each expression in it. */
+
+int
+gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
+{
+ while (*e)
+ {
+ int walk_subtrees = 1;
+ gfc_actual_arglist *a;
+ gfc_ref *r;
+ gfc_constructor *c;
+
+ int result = exprfn (e, &walk_subtrees, data);
+ if (result)
+ return result;
+ if (walk_subtrees)
+ switch ((*e)->expr_type)
+ {
+ case EXPR_OP:
+ WALK_SUBEXPR ((*e)->value.op.op1);
+ WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
+ /* No fallthru because of the tail recursion above. */
+ case EXPR_FUNCTION:
+ for (a = (*e)->value.function.actual; a; a = a->next)
+ WALK_SUBEXPR (a->expr);
+ break;
+ case EXPR_COMPCALL:
+ case EXPR_PPC:
+ WALK_SUBEXPR ((*e)->value.compcall.base_object);
+ for (a = (*e)->value.compcall.actual; a; a = a->next)
+ WALK_SUBEXPR (a->expr);
+ break;
+
+ case EXPR_STRUCTURE:
+ case EXPR_ARRAY:
+ for (c = gfc_constructor_first ((*e)->value.constructor); c;
+ c = gfc_constructor_next (c))
+ {
+ if (c->iterator == NULL)
+ WALK_SUBEXPR (c->expr);
+ else
+ {
+ iterator_level ++;
+ WALK_SUBEXPR (c->expr);
+ iterator_level --;
+ WALK_SUBEXPR (c->iterator->var);
+ WALK_SUBEXPR (c->iterator->start);
+ WALK_SUBEXPR (c->iterator->end);
+ WALK_SUBEXPR (c->iterator->step);
+ }
+ }
+
+ if ((*e)->expr_type != EXPR_ARRAY)
+ break;
+
+ /* Fall through to the variable case in order to walk the
+ reference. */
+ gcc_fallthrough ();
+
+ case EXPR_SUBSTRING:
+ case EXPR_VARIABLE:
+ for (r = (*e)->ref; r; r = r->next)
+ {
+ gfc_array_ref *ar;
+ int i;
+
+ switch (r->type)
+ {
+ case REF_ARRAY:
+ ar = &r->u.ar;
+ if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
+ {
+ for (i=0; i< ar->dimen; i++)
+ {
+ WALK_SUBEXPR (ar->start[i]);
+ WALK_SUBEXPR (ar->end[i]);
+ WALK_SUBEXPR (ar->stride[i]);
+ }
+ }
+
+ break;
+
+ case REF_SUBSTRING:
+ WALK_SUBEXPR (r->u.ss.start);
+ WALK_SUBEXPR (r->u.ss.end);
+ break;
+
+ case REF_COMPONENT:
+ case REF_INQUIRY:
+ break;
+ }
+ }
+
+ default:
+ break;
+ }
+ return 0;
+ }
+ return 0;
+}
+
+#define WALK_SUBCODE(NODE) \
+ do \
+ { \
+ result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
+ if (result) \
+ return result; \
+ } \
+ while (0)
+
+/* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
+ on each expression in it. If any of the hooks returns non-zero, that
+ value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
+ no subcodes or subexpressions are traversed. */
+
+int
+gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
+ void *data)
+{
+ for (; *c; c = &(*c)->next)
+ {
+ int walk_subtrees = 1;
+ int result = codefn (c, &walk_subtrees, data);
+ if (result)
+ return result;
+
+ if (walk_subtrees)
+ {
+ gfc_code *b;
+ gfc_actual_arglist *a;
+ gfc_code *co;
+ gfc_association_list *alist;
+ bool saved_in_omp_workshare;
+ bool saved_in_omp_atomic;
+ bool saved_in_where;
+
+ /* There might be statement insertions before the current code,
+ which must not affect the expression walker. */
+
+ co = *c;
+ saved_in_omp_workshare = in_omp_workshare;
+ saved_in_omp_atomic = in_omp_atomic;
+ saved_in_where = in_where;
+
+ switch (co->op)
+ {
+
+ case EXEC_BLOCK:
+ WALK_SUBCODE (co->ext.block.ns->code);
+ if (co->ext.block.assoc)
+ {
+ bool saved_in_assoc_list = in_assoc_list;
+
+ in_assoc_list = true;
+ for (alist = co->ext.block.assoc; alist; alist = alist->next)
+ WALK_SUBEXPR (alist->target);
+
+ in_assoc_list = saved_in_assoc_list;
+ }
+
+ break;
+
+ case EXEC_DO:
+ doloop_level ++;
+ WALK_SUBEXPR (co->ext.iterator->var);
+ WALK_SUBEXPR (co->ext.iterator->start);
+ WALK_SUBEXPR (co->ext.iterator->end);
+ WALK_SUBEXPR (co->ext.iterator->step);
+ break;
+
+ case EXEC_IF:
+ if_level ++;
+ break;
+
+ case EXEC_WHERE:
+ in_where = true;
+ break;
+
+ case EXEC_CALL:
+ case EXEC_ASSIGN_CALL:
+ for (a = co->ext.actual; a; a = a->next)
+ WALK_SUBEXPR (a->expr);
+ break;
+
+ case EXEC_CALL_PPC:
+ WALK_SUBEXPR (co->expr1);
+ for (a = co->ext.actual; a; a = a->next)
+ WALK_SUBEXPR (a->expr);
+ break;
+
+ case EXEC_SELECT:
+ WALK_SUBEXPR (co->expr1);
+ select_level ++;
+ for (b = co->block; b; b = b->block)
+ {
+ gfc_case *cp;
+ for (cp = b->ext.block.case_list; cp; cp = cp->next)
+ {
+ WALK_SUBEXPR (cp->low);
+ WALK_SUBEXPR (cp->high);
+ }
+ WALK_SUBCODE (b->next);
+ }
+ continue;
+
+ case EXEC_ALLOCATE:
+ case EXEC_DEALLOCATE:
+ {
+ gfc_alloc *a;
+ for (a = co->ext.alloc.list; a; a = a->next)
+ WALK_SUBEXPR (a->expr);
+ break;
+ }
+
+ case EXEC_FORALL:
+ case EXEC_DO_CONCURRENT:
+ {
+ gfc_forall_iterator *fa;
+ for (fa = co->ext.forall_iterator; fa; fa = fa->next)
+ {
+ WALK_SUBEXPR (fa->var);
+ WALK_SUBEXPR (fa->start);
+ WALK_SUBEXPR (fa->end);
+ WALK_SUBEXPR (fa->stride);
+ }
+ if (co->op == EXEC_FORALL)
+ forall_level ++;
+ break;
+ }
+
+ case EXEC_OPEN:
+ WALK_SUBEXPR (co->ext.open->unit);
+ WALK_SUBEXPR (co->ext.open->file);
+ WALK_SUBEXPR (co->ext.open->status);
+ WALK_SUBEXPR (co->ext.open->access);
+ WALK_SUBEXPR (co->ext.open->form);
+ WALK_SUBEXPR (co->ext.open->recl);
+ WALK_SUBEXPR (co->ext.open->blank);
+ WALK_SUBEXPR (co->ext.open->position);
+ WALK_SUBEXPR (co->ext.open->action);
+ WALK_SUBEXPR (co->ext.open->delim);
+ WALK_SUBEXPR (co->ext.open->pad);
+ WALK_SUBEXPR (co->ext.open->iostat);
+ WALK_SUBEXPR (co->ext.open->iomsg);
+ WALK_SUBEXPR (co->ext.open->convert);
+ WALK_SUBEXPR (co->ext.open->decimal);
+ WALK_SUBEXPR (co->ext.open->encoding);
+ WALK_SUBEXPR (co->ext.open->round);
+ WALK_SUBEXPR (co->ext.open->sign);
+ WALK_SUBEXPR (co->ext.open->asynchronous);
+ WALK_SUBEXPR (co->ext.open->id);
+ WALK_SUBEXPR (co->ext.open->newunit);
+ WALK_SUBEXPR (co->ext.open->share);
+ WALK_SUBEXPR (co->ext.open->cc);
+ break;
+
+ case EXEC_CLOSE:
+ WALK_SUBEXPR (co->ext.close->unit);
+ WALK_SUBEXPR (co->ext.close->status);
+ WALK_SUBEXPR (co->ext.close->iostat);
+ WALK_SUBEXPR (co->ext.close->iomsg);
+ break;
+
+ case EXEC_BACKSPACE:
+ case EXEC_ENDFILE:
+ case EXEC_REWIND:
+ case EXEC_FLUSH:
+ WALK_SUBEXPR (co->ext.filepos->unit);
+ WALK_SUBEXPR (co->ext.filepos->iostat);
+ WALK_SUBEXPR (co->ext.filepos->iomsg);
+ break;
+
+ case EXEC_INQUIRE:
+ WALK_SUBEXPR (co->ext.inquire->unit);
+ WALK_SUBEXPR (co->ext.inquire->file);
+ WALK_SUBEXPR (co->ext.inquire->iomsg);
+ WALK_SUBEXPR (co->ext.inquire->iostat);
+ WALK_SUBEXPR (co->ext.inquire->exist);
+ WALK_SUBEXPR (co->ext.inquire->opened);
+ WALK_SUBEXPR (co->ext.inquire->number);
+ WALK_SUBEXPR (co->ext.inquire->named);
+ WALK_SUBEXPR (co->ext.inquire->name);
+ WALK_SUBEXPR (co->ext.inquire->access);
+ WALK_SUBEXPR (co->ext.inquire->sequential);
+ WALK_SUBEXPR (co->ext.inquire->direct);
+ WALK_SUBEXPR (co->ext.inquire->form);
+ WALK_SUBEXPR (co->ext.inquire->formatted);
+ WALK_SUBEXPR (co->ext.inquire->unformatted);
+ WALK_SUBEXPR (co->ext.inquire->recl);
+ WALK_SUBEXPR (co->ext.inquire->nextrec);
+ WALK_SUBEXPR (co->ext.inquire->blank);
+ WALK_SUBEXPR (co->ext.inquire->position);
+ WALK_SUBEXPR (co->ext.inquire->action);
+ WALK_SUBEXPR (co->ext.inquire->read);
+ WALK_SUBEXPR (co->ext.inquire->write);
+ WALK_SUBEXPR (co->ext.inquire->readwrite);
+ WALK_SUBEXPR (co->ext.inquire->delim);
+ WALK_SUBEXPR (co->ext.inquire->encoding);
+ WALK_SUBEXPR (co->ext.inquire->pad);
+ WALK_SUBEXPR (co->ext.inquire->iolength);
+ WALK_SUBEXPR (co->ext.inquire->convert);
+ WALK_SUBEXPR (co->ext.inquire->strm_pos);
+ WALK_SUBEXPR (co->ext.inquire->asynchronous);
+ WALK_SUBEXPR (co->ext.inquire->decimal);
+ WALK_SUBEXPR (co->ext.inquire->pending);
+ WALK_SUBEXPR (co->ext.inquire->id);
+ WALK_SUBEXPR (co->ext.inquire->sign);
+ WALK_SUBEXPR (co->ext.inquire->size);
+ WALK_SUBEXPR (co->ext.inquire->round);
+ break;
+
+ case EXEC_WAIT:
+ WALK_SUBEXPR (co->ext.wait->unit);
+ WALK_SUBEXPR (co->ext.wait->iostat);
+ WALK_SUBEXPR (co->ext.wait->iomsg);
+ WALK_SUBEXPR (co->ext.wait->id);
+ break;
+
+ case EXEC_READ:
+ case EXEC_WRITE:
+ WALK_SUBEXPR (co->ext.dt->io_unit);
+ WALK_SUBEXPR (co->ext.dt->format_expr);
+ WALK_SUBEXPR (co->ext.dt->rec);
+ WALK_SUBEXPR (co->ext.dt->advance);
+ WALK_SUBEXPR (co->ext.dt->iostat);
+ WALK_SUBEXPR (co->ext.dt->size);
+ WALK_SUBEXPR (co->ext.dt->iomsg);
+ WALK_SUBEXPR (co->ext.dt->id);
+ WALK_SUBEXPR (co->ext.dt->pos);
+ WALK_SUBEXPR (co->ext.dt->asynchronous);
+ WALK_SUBEXPR (co->ext.dt->blank);
+ WALK_SUBEXPR (co->ext.dt->decimal);
+ WALK_SUBEXPR (co->ext.dt->delim);
+ WALK_SUBEXPR (co->ext.dt->pad);
+ WALK_SUBEXPR (co->ext.dt->round);
+ WALK_SUBEXPR (co->ext.dt->sign);
+ WALK_SUBEXPR (co->ext.dt->extra_comma);
+ break;
+
+ case EXEC_OACC_ATOMIC:
+ case EXEC_OMP_ATOMIC:
+ in_omp_atomic = true;
+ break;
+
+ case EXEC_OMP_PARALLEL:
+ case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_DO_SIMD:
+ case EXEC_OMP_PARALLEL_LOOP:
+ case EXEC_OMP_PARALLEL_MASKED:
+ case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
+ case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
+ case EXEC_OMP_PARALLEL_MASTER:
+ case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
+ case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
+ case EXEC_OMP_PARALLEL_SECTIONS:
+
+ in_omp_workshare = false;
+
+ /* This goto serves as a shortcut to avoid code
+ duplication or a larger if or switch statement. */
+ goto check_omp_clauses;
+
+ case EXEC_OMP_WORKSHARE:
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+
+ in_omp_workshare = true;
+
+ /* Fall through */
+
+ case EXEC_OMP_CRITICAL:
+ case EXEC_OMP_DISTRIBUTE:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case EXEC_OMP_DISTRIBUTE_SIMD:
+ case EXEC_OMP_DO:
+ case EXEC_OMP_DO_SIMD:
+ case EXEC_OMP_LOOP:
+ case EXEC_OMP_ORDERED:
+ case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SINGLE:
+ case EXEC_OMP_END_SINGLE:
+ case EXEC_OMP_SIMD:
+ case EXEC_OMP_TASKLOOP:
+ case EXEC_OMP_TASKLOOP_SIMD:
+ case EXEC_OMP_TARGET:
+ case EXEC_OMP_TARGET_DATA:
+ case EXEC_OMP_TARGET_ENTER_DATA:
+ case EXEC_OMP_TARGET_EXIT_DATA:
+ case EXEC_OMP_TARGET_PARALLEL:
+ case EXEC_OMP_TARGET_PARALLEL_DO:
+ case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
+ case EXEC_OMP_TARGET_PARALLEL_LOOP:
+ case EXEC_OMP_TARGET_SIMD:
+ case EXEC_OMP_TARGET_TEAMS:
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
+ case EXEC_OMP_TARGET_TEAMS_LOOP:
+ case EXEC_OMP_TARGET_UPDATE:
+ case EXEC_OMP_TASK:
+ case EXEC_OMP_TEAMS:
+ case EXEC_OMP_TEAMS_DISTRIBUTE:
+ case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
+ case EXEC_OMP_TEAMS_LOOP:
+
+ /* Come to this label only from the
+ EXEC_OMP_PARALLEL_* cases above. */
+
+ check_omp_clauses:
+
+ if (co->ext.omp_clauses)
+ {
+ gfc_omp_namelist *n;
+ static int list_types[]
+ = { OMP_LIST_ALIGNED, OMP_LIST_LINEAR, OMP_LIST_DEPEND,
+ OMP_LIST_MAP, OMP_LIST_TO, OMP_LIST_FROM };
+ size_t idx;
+ WALK_SUBEXPR (co->ext.omp_clauses->if_expr);
+ WALK_SUBEXPR (co->ext.omp_clauses->final_expr);
+ WALK_SUBEXPR (co->ext.omp_clauses->num_threads);
+ WALK_SUBEXPR (co->ext.omp_clauses->chunk_size);
+ WALK_SUBEXPR (co->ext.omp_clauses->safelen_expr);
+ WALK_SUBEXPR (co->ext.omp_clauses->simdlen_expr);
+ WALK_SUBEXPR (co->ext.omp_clauses->num_teams_lower);
+ WALK_SUBEXPR (co->ext.omp_clauses->num_teams_upper);
+ WALK_SUBEXPR (co->ext.omp_clauses->device);
+ WALK_SUBEXPR (co->ext.omp_clauses->thread_limit);
+ WALK_SUBEXPR (co->ext.omp_clauses->dist_chunk_size);
+ WALK_SUBEXPR (co->ext.omp_clauses->grainsize);
+ WALK_SUBEXPR (co->ext.omp_clauses->hint);
+ WALK_SUBEXPR (co->ext.omp_clauses->num_tasks);
+ WALK_SUBEXPR (co->ext.omp_clauses->priority);
+ WALK_SUBEXPR (co->ext.omp_clauses->detach);
+ for (idx = 0; idx < OMP_IF_LAST; idx++)
+ WALK_SUBEXPR (co->ext.omp_clauses->if_exprs[idx]);
+ for (idx = 0;
+ idx < sizeof (list_types) / sizeof (list_types[0]);
+ idx++)
+ for (n = co->ext.omp_clauses->lists[list_types[idx]];
+ n; n = n->next)
+ WALK_SUBEXPR (n->expr);
+ }
+ break;
+ default:
+ break;
+ }
+
+ WALK_SUBEXPR (co->expr1);
+ WALK_SUBEXPR (co->expr2);
+ WALK_SUBEXPR (co->expr3);
+ WALK_SUBEXPR (co->expr4);
+ for (b = co->block; b; b = b->block)
+ {
+ WALK_SUBEXPR (b->expr1);
+ WALK_SUBEXPR (b->expr2);
+ WALK_SUBCODE (b->next);
+ }
+
+ if (co->op == EXEC_FORALL)
+ forall_level --;
+
+ if (co->op == EXEC_DO)
+ doloop_level --;
+
+ if (co->op == EXEC_IF)
+ if_level --;
+
+ if (co->op == EXEC_SELECT)
+ select_level --;
+
+ in_omp_workshare = saved_in_omp_workshare;
+ in_omp_atomic = saved_in_omp_atomic;
+ in_where = saved_in_where;
+ }
+ }
+ return 0;
+}
+
+/* As a post-resolution step, check that all global symbols which are
+ not declared in the source file match in their call signatures.
+ We do this by looping over the code (and expressions). The first call
+ we happen to find is assumed to be canonical. */
+
+
+/* Common tests for argument checking for both functions and subroutines. */
+
+static int
+check_externals_procedure (gfc_symbol *sym, locus *loc,
+ gfc_actual_arglist *actual)
+{
+ gfc_gsymbol *gsym;
+ gfc_symbol *def_sym = NULL;
+
+ if (sym == NULL || sym->attr.is_bind_c)
+ return 0;
+
+ if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN)
+ return 0;
+
+ if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.if_source == IFSRC_DECL)
+ return 0;
+
+ gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
+ if (gsym == NULL)
+ return 0;
+
+ if (gsym->ns)
+ gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
+
+ if (def_sym)
+ {
+ gfc_compare_actual_formal (&actual, def_sym->formal, 0, 0, 0, loc);
+ return 0;
+ }
+
+ /* First time we have seen this procedure called. Let's create an
+ "interface" from the call and put it into a new namespace. */
+ gfc_namespace *save_ns;
+ gfc_symbol *new_sym;
+
+ gsym->where = *loc;
+ save_ns = gfc_current_ns;
+ gsym->ns = gfc_get_namespace (gfc_current_ns, 0);
+ gsym->ns->proc_name = sym;
+
+ gfc_get_symbol (sym->name, gsym->ns, &new_sym);
+ gcc_assert (new_sym);
+ new_sym->attr = sym->attr;
+ new_sym->attr.if_source = IFSRC_DECL;
+ gfc_current_ns = gsym->ns;
+
+ gfc_get_formal_from_actual_arglist (new_sym, actual);
+ new_sym->declared_at = *loc;
+ gfc_current_ns = save_ns;
+
+ return 0;
+
+}
+
+/* Callback for calls of external routines. */
+
+static int
+check_externals_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_code *co = *c;
+ gfc_symbol *sym;
+ locus *loc;
+ gfc_actual_arglist *actual;
+
+ if (co->op != EXEC_CALL)
+ return 0;
+
+ sym = co->resolved_sym;
+ loc = &co->loc;
+ actual = co->ext.actual;
+
+ return check_externals_procedure (sym, loc, actual);
+
+}
+
+/* Callback for external functions. */
+
+static int
+check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_expr *e = *ep;
+ gfc_symbol *sym;
+ locus *loc;
+ gfc_actual_arglist *actual;
+
+ if (e->expr_type != EXPR_FUNCTION)
+ return 0;
+
+ sym = e->value.function.esym;
+ if (sym == NULL)
+ return 0;
+
+ loc = &e->where;
+ actual = e->value.function.actual;
+
+ return check_externals_procedure (sym, loc, actual);
+}
+
+/* Function to check if any interface clashes with a global
+ identifier, to be invoked via gfc_traverse_ns. */
+
+static void
+check_against_globals (gfc_symbol *sym)
+{
+ gfc_gsymbol *gsym;
+ gfc_symbol *def_sym = NULL;
+ const char *sym_name;
+ char buf [200];
+
+ if (sym->attr.if_source != IFSRC_IFBODY || sym->attr.flavor != FL_PROCEDURE
+ || sym->attr.generic || sym->error)
+ return;
+
+ if (sym->binding_label)
+ sym_name = sym->binding_label;
+ else
+ sym_name = sym->name;
+
+ gsym = gfc_find_gsymbol (gfc_gsym_root, sym_name);
+ if (gsym && gsym->ns)
+ gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
+
+ if (!def_sym || def_sym->error || def_sym->attr.generic)
+ return;
+
+ buf[0] = 0;
+ gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1, buf, sizeof(buf),
+ NULL, NULL, NULL);
+ if (buf[0] != 0)
+ {
+ gfc_warning (0, "%s between %L and %L", buf, &def_sym->declared_at,
+ &sym->declared_at);
+ sym->error = 1;
+ def_sym->error = 1;
+ }
+
+}
+
+/* Do the code-walkling part for gfc_check_externals. */
+
+static void
+gfc_check_externals0 (gfc_namespace *ns)
+{
+ gfc_code_walker (&ns->code, check_externals_code, check_externals_expr, NULL);
+
+ for (ns = ns->contained; ns; ns = ns->sibling)
+ {
+ if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
+ gfc_check_externals0 (ns);
+ }
+
+}
+
+/* Called routine. */
+
+void
+gfc_check_externals (gfc_namespace *ns)
+{
+ gfc_clear_error ();
+
+ /* Turn errors into warnings if the user indicated this. */
+
+ if (!pedantic && flag_allow_argument_mismatch)
+ gfc_errors_to_warnings (true);
+
+ gfc_check_externals0 (ns);
+ gfc_traverse_ns (ns, check_against_globals);
+
+ gfc_errors_to_warnings (false);
+}
+
+/* Callback function. If there is a call to a subroutine which is
+ neither pure nor implicit_pure, unset the implicit_pure flag for
+ the caller and return -1. */
+
+static int
+implicit_pure_call (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *sym_data)
+{
+ gfc_code *co = *c;
+ gfc_symbol *caller_sym;
+ symbol_attribute *a;
+
+ if (co->op != EXEC_CALL || co->resolved_sym == NULL)
+ return 0;
+
+ a = &co->resolved_sym->attr;
+ if (a->intrinsic || a->pure || a->implicit_pure)
+ return 0;
+
+ caller_sym = (gfc_symbol *) sym_data;
+ gfc_unset_implicit_pure (caller_sym);
+ return 1;
+}
+
+/* Callback function. If there is a call to a function which is
+ neither pure nor implicit_pure, unset the implicit_pure flag for
+ the caller and return 1. */
+
+static int
+implicit_pure_expr (gfc_expr **e, int *walk ATTRIBUTE_UNUSED, void *sym_data)
+{
+ gfc_expr *expr = *e;
+ gfc_symbol *caller_sym;
+ gfc_symbol *sym;
+ symbol_attribute *a;
+
+ if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym)
+ return 0;
+
+ sym = expr->symtree->n.sym;
+ a = &sym->attr;
+ if (a->pure || a->implicit_pure)
+ return 0;
+
+ caller_sym = (gfc_symbol *) sym_data;
+ gfc_unset_implicit_pure (caller_sym);
+ return 1;
+}
+
+/* Go through all procedures in the namespace and unset the
+ implicit_pure attribute for any procedure that calls something not
+ pure or implicit pure. */
+
+bool
+gfc_fix_implicit_pure (gfc_namespace *ns)
+{
+ bool changed = false;
+ gfc_symbol *proc = ns->proc_name;
+
+ if (proc && proc->attr.flavor == FL_PROCEDURE && proc->attr.implicit_pure
+ && ns->code
+ && gfc_code_walker (&ns->code, implicit_pure_call, implicit_pure_expr,
+ (void *) ns->proc_name))
+ changed = true;
+
+ for (ns = ns->contained; ns; ns = ns->sibling)
+ {
+ if (gfc_fix_implicit_pure (ns))
+ changed = true;
+ }
+
+ return changed;
+}
generated by cgit v1.1 at 2025-05-21 21:40:08 +0000