aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/frontend-passes.c
diff options
context:
space:
mode:
authorMartin Liska <mliska@suse.cz>2022-01-14 16:56:44 +0100
committerMartin Liska <mliska@suse.cz>2022-01-17 22:12:04 +0100
commit5c69acb32329d49e58c26fa41ae74229a52b9106 (patch)
treeddb05f9d73afb6f998457d2ac4b720e3b3b60483 /gcc/fortran/frontend-passes.c
parent490e23032baaece71f2ec09fa1805064b150fbc2 (diff)
downloadgcc-5c69acb32329d49e58c26fa41ae74229a52b9106.zip
gcc-5c69acb32329d49e58c26fa41ae74229a52b9106.tar.gz
gcc-5c69acb32329d49e58c26fa41ae74229a52b9106.tar.bz2
Rename .c files to .cc files.
gcc/ada/ChangeLog: * adadecode.c: Moved to... * adadecode.cc: ...here. * affinity.c: Moved to... * affinity.cc: ...here. * argv-lynxos178-raven-cert.c: Moved to... * argv-lynxos178-raven-cert.cc: ...here. * argv.c: Moved to... * argv.cc: ...here. * aux-io.c: Moved to... * aux-io.cc: ...here. * cio.c: Moved to... * cio.cc: ...here. * cstreams.c: Moved to... * cstreams.cc: ...here. * env.c: Moved to... * env.cc: ...here. * exit.c: Moved to... * exit.cc: ...here. * expect.c: Moved to... * expect.cc: ...here. * final.c: Moved to... * final.cc: ...here. * gcc-interface/cuintp.c: Moved to... * gcc-interface/cuintp.cc: ...here. * gcc-interface/decl.c: Moved to... * gcc-interface/decl.cc: ...here. * gcc-interface/misc.c: Moved to... * gcc-interface/misc.cc: ...here. * gcc-interface/targtyps.c: Moved to... * gcc-interface/targtyps.cc: ...here. * gcc-interface/trans.c: Moved to... * gcc-interface/trans.cc: ...here. * gcc-interface/utils.c: Moved to... * gcc-interface/utils.cc: ...here. * gcc-interface/utils2.c: Moved to... * gcc-interface/utils2.cc: ...here. * init.c: Moved to... * init.cc: ...here. * initialize.c: Moved to... * initialize.cc: ...here. * libgnarl/thread.c: Moved to... * libgnarl/thread.cc: ...here. * link.c: Moved to... * link.cc: ...here. * locales.c: Moved to... * locales.cc: ...here. * mkdir.c: Moved to... * mkdir.cc: ...here. * raise.c: Moved to... * raise.cc: ...here. * rtfinal.c: Moved to... * rtfinal.cc: ...here. * rtinit.c: Moved to... * rtinit.cc: ...here. * seh_init.c: Moved to... * seh_init.cc: ...here. * sigtramp-armdroid.c: Moved to... * sigtramp-armdroid.cc: ...here. * sigtramp-ios.c: Moved to... * sigtramp-ios.cc: ...here. * sigtramp-qnx.c: Moved to... * sigtramp-qnx.cc: ...here. * sigtramp-vxworks.c: Moved to... * sigtramp-vxworks.cc: ...here. * socket.c: Moved to... * socket.cc: ...here. * tracebak.c: Moved to... * tracebak.cc: ...here. * version.c: Moved to... * version.cc: ...here. * vx_stack_info.c: Moved to... * vx_stack_info.cc: ...here. gcc/ChangeLog: * adjust-alignment.c: Moved to... * adjust-alignment.cc: ...here. * alias.c: Moved to... * alias.cc: ...here. * alloc-pool.c: Moved to... * alloc-pool.cc: ...here. * asan.c: Moved to... * asan.cc: ...here. * attribs.c: Moved to... * attribs.cc: ...here. * auto-inc-dec.c: Moved to... * auto-inc-dec.cc: ...here. * auto-profile.c: Moved to... * auto-profile.cc: ...here. * bb-reorder.c: Moved to... * bb-reorder.cc: ...here. * bitmap.c: Moved to... * bitmap.cc: ...here. * btfout.c: Moved to... * btfout.cc: ...here. * builtins.c: Moved to... * builtins.cc: ...here. * caller-save.c: Moved to... * caller-save.cc: ...here. * calls.c: Moved to... * calls.cc: ...here. * ccmp.c: Moved to... * ccmp.cc: ...here. * cfg.c: Moved to... * cfg.cc: ...here. * cfganal.c: Moved to... * cfganal.cc: ...here. * cfgbuild.c: Moved to... * cfgbuild.cc: ...here. * cfgcleanup.c: Moved to... * cfgcleanup.cc: ...here. * cfgexpand.c: Moved to... * cfgexpand.cc: ...here. * cfghooks.c: Moved to... * cfghooks.cc: ...here. * cfgloop.c: Moved to... * cfgloop.cc: ...here. * cfgloopanal.c: Moved to... * cfgloopanal.cc: ...here. * cfgloopmanip.c: Moved to... * cfgloopmanip.cc: ...here. * cfgrtl.c: Moved to... * cfgrtl.cc: ...here. * cgraph.c: Moved to... * cgraph.cc: ...here. * cgraphbuild.c: Moved to... * cgraphbuild.cc: ...here. * cgraphclones.c: Moved to... * cgraphclones.cc: ...here. * cgraphunit.c: Moved to... * cgraphunit.cc: ...here. * collect-utils.c: Moved to... * collect-utils.cc: ...here. * collect2-aix.c: Moved to... * collect2-aix.cc: ...here. * collect2.c: Moved to... * collect2.cc: ...here. * combine-stack-adj.c: Moved to... * combine-stack-adj.cc: ...here. * combine.c: Moved to... * combine.cc: ...here. * common/common-targhooks.c: Moved to... * common/common-targhooks.cc: ...here. * common/config/aarch64/aarch64-common.c: Moved to... * common/config/aarch64/aarch64-common.cc: ...here. * common/config/alpha/alpha-common.c: Moved to... * common/config/alpha/alpha-common.cc: ...here. * common/config/arc/arc-common.c: Moved to... * common/config/arc/arc-common.cc: ...here. * common/config/arm/arm-common.c: Moved to... * common/config/arm/arm-common.cc: ...here. * common/config/avr/avr-common.c: Moved to... * common/config/avr/avr-common.cc: ...here. * common/config/bfin/bfin-common.c: Moved to... * common/config/bfin/bfin-common.cc: ...here. * common/config/bpf/bpf-common.c: Moved to... * common/config/bpf/bpf-common.cc: ...here. * common/config/c6x/c6x-common.c: Moved to... * common/config/c6x/c6x-common.cc: ...here. * common/config/cr16/cr16-common.c: Moved to... * common/config/cr16/cr16-common.cc: ...here. * common/config/cris/cris-common.c: Moved to... * common/config/cris/cris-common.cc: ...here. * common/config/csky/csky-common.c: Moved to... * common/config/csky/csky-common.cc: ...here. * common/config/default-common.c: Moved to... * common/config/default-common.cc: ...here. * common/config/epiphany/epiphany-common.c: Moved to... * common/config/epiphany/epiphany-common.cc: ...here. * common/config/fr30/fr30-common.c: Moved to... * common/config/fr30/fr30-common.cc: ...here. * common/config/frv/frv-common.c: Moved to... * common/config/frv/frv-common.cc: ...here. * common/config/gcn/gcn-common.c: Moved to... * common/config/gcn/gcn-common.cc: ...here. * common/config/h8300/h8300-common.c: Moved to... * common/config/h8300/h8300-common.cc: ...here. * common/config/i386/i386-common.c: Moved to... * common/config/i386/i386-common.cc: ...here. * common/config/ia64/ia64-common.c: Moved to... * common/config/ia64/ia64-common.cc: ...here. * common/config/iq2000/iq2000-common.c: Moved to... * common/config/iq2000/iq2000-common.cc: ...here. * common/config/lm32/lm32-common.c: Moved to... * common/config/lm32/lm32-common.cc: ...here. * common/config/m32r/m32r-common.c: Moved to... * common/config/m32r/m32r-common.cc: ...here. * common/config/m68k/m68k-common.c: Moved to... * common/config/m68k/m68k-common.cc: ...here. * common/config/mcore/mcore-common.c: Moved to... * common/config/mcore/mcore-common.cc: ...here. * common/config/microblaze/microblaze-common.c: Moved to... * common/config/microblaze/microblaze-common.cc: ...here. * common/config/mips/mips-common.c: Moved to... * common/config/mips/mips-common.cc: ...here. * common/config/mmix/mmix-common.c: Moved to... * common/config/mmix/mmix-common.cc: ...here. * common/config/mn10300/mn10300-common.c: Moved to... * common/config/mn10300/mn10300-common.cc: ...here. * common/config/msp430/msp430-common.c: Moved to... * common/config/msp430/msp430-common.cc: ...here. * common/config/nds32/nds32-common.c: Moved to... * common/config/nds32/nds32-common.cc: ...here. * common/config/nios2/nios2-common.c: Moved to... * common/config/nios2/nios2-common.cc: ...here. * common/config/nvptx/nvptx-common.c: Moved to... * common/config/nvptx/nvptx-common.cc: ...here. * common/config/or1k/or1k-common.c: Moved to... * common/config/or1k/or1k-common.cc: ...here. * common/config/pa/pa-common.c: Moved to... * common/config/pa/pa-common.cc: ...here. * common/config/pdp11/pdp11-common.c: Moved to... * common/config/pdp11/pdp11-common.cc: ...here. * common/config/pru/pru-common.c: Moved to... * common/config/pru/pru-common.cc: ...here. * common/config/riscv/riscv-common.c: Moved to... * common/config/riscv/riscv-common.cc: ...here. * common/config/rs6000/rs6000-common.c: Moved to... * common/config/rs6000/rs6000-common.cc: ...here. * common/config/rx/rx-common.c: Moved to... * common/config/rx/rx-common.cc: ...here. * common/config/s390/s390-common.c: Moved to... * common/config/s390/s390-common.cc: ...here. * common/config/sh/sh-common.c: Moved to... * common/config/sh/sh-common.cc: ...here. * common/config/sparc/sparc-common.c: Moved to... * common/config/sparc/sparc-common.cc: ...here. * common/config/tilegx/tilegx-common.c: Moved to... * common/config/tilegx/tilegx-common.cc: ...here. * common/config/tilepro/tilepro-common.c: Moved to... * common/config/tilepro/tilepro-common.cc: ...here. * common/config/v850/v850-common.c: Moved to... * common/config/v850/v850-common.cc: ...here. * common/config/vax/vax-common.c: Moved to... * common/config/vax/vax-common.cc: ...here. * common/config/visium/visium-common.c: Moved to... * common/config/visium/visium-common.cc: ...here. * common/config/xstormy16/xstormy16-common.c: Moved to... * common/config/xstormy16/xstormy16-common.cc: ...here. * common/config/xtensa/xtensa-common.c: Moved to... * common/config/xtensa/xtensa-common.cc: ...here. * compare-elim.c: Moved to... * compare-elim.cc: ...here. * config/aarch64/aarch64-bti-insert.c: Moved to... * config/aarch64/aarch64-bti-insert.cc: ...here. * config/aarch64/aarch64-builtins.c: Moved to... * config/aarch64/aarch64-builtins.cc: ...here. * config/aarch64/aarch64-c.c: Moved to... * config/aarch64/aarch64-c.cc: ...here. * config/aarch64/aarch64-d.c: Moved to... * config/aarch64/aarch64-d.cc: ...here. * config/aarch64/aarch64.c: Moved to... * config/aarch64/aarch64.cc: ...here. * config/aarch64/cortex-a57-fma-steering.c: Moved to... * config/aarch64/cortex-a57-fma-steering.cc: ...here. * config/aarch64/driver-aarch64.c: Moved to... * config/aarch64/driver-aarch64.cc: ...here. * config/aarch64/falkor-tag-collision-avoidance.c: Moved to... * config/aarch64/falkor-tag-collision-avoidance.cc: ...here. * config/aarch64/host-aarch64-darwin.c: Moved to... * config/aarch64/host-aarch64-darwin.cc: ...here. * config/alpha/alpha.c: Moved to... * config/alpha/alpha.cc: ...here. * config/alpha/driver-alpha.c: Moved to... * config/alpha/driver-alpha.cc: ...here. * config/arc/arc-c.c: Moved to... * config/arc/arc-c.cc: ...here. * config/arc/arc.c: Moved to... * config/arc/arc.cc: ...here. * config/arc/driver-arc.c: Moved to... * config/arc/driver-arc.cc: ...here. * config/arm/aarch-common.c: Moved to... * config/arm/aarch-common.cc: ...here. * config/arm/arm-builtins.c: Moved to... * config/arm/arm-builtins.cc: ...here. * config/arm/arm-c.c: Moved to... * config/arm/arm-c.cc: ...here. * config/arm/arm-d.c: Moved to... * config/arm/arm-d.cc: ...here. * config/arm/arm.c: Moved to... * config/arm/arm.cc: ...here. * config/arm/driver-arm.c: Moved to... * config/arm/driver-arm.cc: ...here. * config/avr/avr-c.c: Moved to... * config/avr/avr-c.cc: ...here. * config/avr/avr-devices.c: Moved to... * config/avr/avr-devices.cc: ...here. * config/avr/avr-log.c: Moved to... * config/avr/avr-log.cc: ...here. * config/avr/avr.c: Moved to... * config/avr/avr.cc: ...here. * config/avr/driver-avr.c: Moved to... * config/avr/driver-avr.cc: ...here. * config/avr/gen-avr-mmcu-specs.c: Moved to... * config/avr/gen-avr-mmcu-specs.cc: ...here. * config/avr/gen-avr-mmcu-texi.c: Moved to... * config/avr/gen-avr-mmcu-texi.cc: ...here. * config/bfin/bfin.c: Moved to... * config/bfin/bfin.cc: ...here. * config/bpf/bpf.c: Moved to... * config/bpf/bpf.cc: ...here. * config/bpf/coreout.c: Moved to... * config/bpf/coreout.cc: ...here. * config/c6x/c6x.c: Moved to... * config/c6x/c6x.cc: ...here. * config/cr16/cr16.c: Moved to... * config/cr16/cr16.cc: ...here. * config/cris/cris.c: Moved to... * config/cris/cris.cc: ...here. * config/csky/csky.c: Moved to... * config/csky/csky.cc: ...here. * config/darwin-c.c: Moved to... * config/darwin-c.cc: ...here. * config/darwin-d.c: Moved to... * config/darwin-d.cc: ...here. * config/darwin-driver.c: Moved to... * config/darwin-driver.cc: ...here. * config/darwin-f.c: Moved to... * config/darwin-f.cc: ...here. * config/darwin.c: Moved to... * config/darwin.cc: ...here. * config/default-c.c: Moved to... * config/default-c.cc: ...here. * config/default-d.c: Moved to... * config/default-d.cc: ...here. * config/dragonfly-d.c: Moved to... * config/dragonfly-d.cc: ...here. * config/epiphany/epiphany.c: Moved to... * config/epiphany/epiphany.cc: ...here. * config/epiphany/mode-switch-use.c: Moved to... * config/epiphany/mode-switch-use.cc: ...here. * config/epiphany/resolve-sw-modes.c: Moved to... * config/epiphany/resolve-sw-modes.cc: ...here. * config/fr30/fr30.c: Moved to... * config/fr30/fr30.cc: ...here. * config/freebsd-d.c: Moved to... * config/freebsd-d.cc: ...here. * config/frv/frv.c: Moved to... * config/frv/frv.cc: ...here. * config/ft32/ft32.c: Moved to... * config/ft32/ft32.cc: ...here. * config/gcn/driver-gcn.c: Moved to... * config/gcn/driver-gcn.cc: ...here. * config/gcn/gcn-run.c: Moved to... * config/gcn/gcn-run.cc: ...here. * config/gcn/gcn-tree.c: Moved to... * config/gcn/gcn-tree.cc: ...here. * config/gcn/gcn.c: Moved to... * config/gcn/gcn.cc: ...here. * config/gcn/mkoffload.c: Moved to... * config/gcn/mkoffload.cc: ...here. * config/glibc-c.c: Moved to... * config/glibc-c.cc: ...here. * config/glibc-d.c: Moved to... * config/glibc-d.cc: ...here. * config/h8300/h8300.c: Moved to... * config/h8300/h8300.cc: ...here. * config/host-darwin.c: Moved to... * config/host-darwin.cc: ...here. * config/host-hpux.c: Moved to... * config/host-hpux.cc: ...here. * config/host-linux.c: Moved to... * config/host-linux.cc: ...here. * config/host-netbsd.c: Moved to... * config/host-netbsd.cc: ...here. * config/host-openbsd.c: Moved to... * config/host-openbsd.cc: ...here. * config/host-solaris.c: Moved to... * config/host-solaris.cc: ...here. * config/i386/djgpp.c: Moved to... * config/i386/djgpp.cc: ...here. * config/i386/driver-i386.c: Moved to... * config/i386/driver-i386.cc: ...here. * config/i386/driver-mingw32.c: Moved to... * config/i386/driver-mingw32.cc: ...here. * config/i386/gnu-property.c: Moved to... * config/i386/gnu-property.cc: ...here. * config/i386/host-cygwin.c: Moved to... * config/i386/host-cygwin.cc: ...here. * config/i386/host-i386-darwin.c: Moved to... * config/i386/host-i386-darwin.cc: ...here. * config/i386/host-mingw32.c: Moved to... * config/i386/host-mingw32.cc: ...here. * config/i386/i386-builtins.c: Moved to... * config/i386/i386-builtins.cc: ...here. * config/i386/i386-c.c: Moved to... * config/i386/i386-c.cc: ...here. * config/i386/i386-d.c: Moved to... * config/i386/i386-d.cc: ...here. * config/i386/i386-expand.c: Moved to... * config/i386/i386-expand.cc: ...here. * config/i386/i386-features.c: Moved to... * config/i386/i386-features.cc: ...here. * config/i386/i386-options.c: Moved to... * config/i386/i386-options.cc: ...here. * config/i386/i386.c: Moved to... * config/i386/i386.cc: ...here. * config/i386/intelmic-mkoffload.c: Moved to... * config/i386/intelmic-mkoffload.cc: ...here. * config/i386/msformat-c.c: Moved to... * config/i386/msformat-c.cc: ...here. * config/i386/winnt-cxx.c: Moved to... * config/i386/winnt-cxx.cc: ...here. * config/i386/winnt-d.c: Moved to... * config/i386/winnt-d.cc: ...here. * config/i386/winnt-stubs.c: Moved to... * config/i386/winnt-stubs.cc: ...here. * config/i386/winnt.c: Moved to... * config/i386/winnt.cc: ...here. * config/i386/x86-tune-sched-atom.c: Moved to... * config/i386/x86-tune-sched-atom.cc: ...here. * config/i386/x86-tune-sched-bd.c: Moved to... * config/i386/x86-tune-sched-bd.cc: ...here. * config/i386/x86-tune-sched-core.c: Moved to... * config/i386/x86-tune-sched-core.cc: ...here. * config/i386/x86-tune-sched.c: Moved to... * config/i386/x86-tune-sched.cc: ...here. * config/ia64/ia64-c.c: Moved to... * config/ia64/ia64-c.cc: ...here. * config/ia64/ia64.c: Moved to... * config/ia64/ia64.cc: ...here. * config/iq2000/iq2000.c: Moved to... * config/iq2000/iq2000.cc: ...here. * config/linux.c: Moved to... * config/linux.cc: ...here. * config/lm32/lm32.c: Moved to... * config/lm32/lm32.cc: ...here. * config/m32c/m32c-pragma.c: Moved to... * config/m32c/m32c-pragma.cc: ...here. * config/m32c/m32c.c: Moved to... * config/m32c/m32c.cc: ...here. * config/m32r/m32r.c: Moved to... * config/m32r/m32r.cc: ...here. * config/m68k/m68k.c: Moved to... * config/m68k/m68k.cc: ...here. * config/mcore/mcore.c: Moved to... * config/mcore/mcore.cc: ...here. * config/microblaze/microblaze-c.c: Moved to... * config/microblaze/microblaze-c.cc: ...here. * config/microblaze/microblaze.c: Moved to... * config/microblaze/microblaze.cc: ...here. * config/mips/driver-native.c: Moved to... * config/mips/driver-native.cc: ...here. * config/mips/frame-header-opt.c: Moved to... * config/mips/frame-header-opt.cc: ...here. * config/mips/mips-d.c: Moved to... * config/mips/mips-d.cc: ...here. * config/mips/mips.c: Moved to... * config/mips/mips.cc: ...here. * config/mmix/mmix.c: Moved to... * config/mmix/mmix.cc: ...here. * config/mn10300/mn10300.c: Moved to... * config/mn10300/mn10300.cc: ...here. * config/moxie/moxie.c: Moved to... * config/moxie/moxie.cc: ...here. * config/msp430/driver-msp430.c: Moved to... * config/msp430/driver-msp430.cc: ...here. * config/msp430/msp430-c.c: Moved to... * config/msp430/msp430-c.cc: ...here. * config/msp430/msp430-devices.c: Moved to... * config/msp430/msp430-devices.cc: ...here. * config/msp430/msp430.c: Moved to... * config/msp430/msp430.cc: ...here. * config/nds32/nds32-cost.c: Moved to... * config/nds32/nds32-cost.cc: ...here. * config/nds32/nds32-fp-as-gp.c: Moved to... * config/nds32/nds32-fp-as-gp.cc: ...here. * config/nds32/nds32-intrinsic.c: Moved to... * config/nds32/nds32-intrinsic.cc: ...here. * config/nds32/nds32-isr.c: Moved to... * config/nds32/nds32-isr.cc: ...here. * config/nds32/nds32-md-auxiliary.c: Moved to... * config/nds32/nds32-md-auxiliary.cc: ...here. * config/nds32/nds32-memory-manipulation.c: Moved to... * config/nds32/nds32-memory-manipulation.cc: ...here. * config/nds32/nds32-pipelines-auxiliary.c: Moved to... * config/nds32/nds32-pipelines-auxiliary.cc: ...here. * config/nds32/nds32-predicates.c: Moved to... * config/nds32/nds32-predicates.cc: ...here. * config/nds32/nds32-relax-opt.c: Moved to... * config/nds32/nds32-relax-opt.cc: ...here. * config/nds32/nds32-utils.c: Moved to... * config/nds32/nds32-utils.cc: ...here. * config/nds32/nds32.c: Moved to... * config/nds32/nds32.cc: ...here. * config/netbsd-d.c: Moved to... * config/netbsd-d.cc: ...here. * config/netbsd.c: Moved to... * config/netbsd.cc: ...here. * config/nios2/nios2.c: Moved to... * config/nios2/nios2.cc: ...here. * config/nvptx/mkoffload.c: Moved to... * config/nvptx/mkoffload.cc: ...here. * config/nvptx/nvptx-c.c: Moved to... * config/nvptx/nvptx-c.cc: ...here. * config/nvptx/nvptx.c: Moved to... * config/nvptx/nvptx.cc: ...here. * config/openbsd-d.c: Moved to... * config/openbsd-d.cc: ...here. * config/or1k/or1k.c: Moved to... * config/or1k/or1k.cc: ...here. * config/pa/pa-d.c: Moved to... * config/pa/pa-d.cc: ...here. * config/pa/pa.c: Moved to... * config/pa/pa.cc: ...here. * config/pdp11/pdp11.c: Moved to... * config/pdp11/pdp11.cc: ...here. * config/pru/pru-passes.c: Moved to... * config/pru/pru-passes.cc: ...here. * config/pru/pru-pragma.c: Moved to... * config/pru/pru-pragma.cc: ...here. * config/pru/pru.c: Moved to... * config/pru/pru.cc: ...here. * config/riscv/riscv-builtins.c: Moved to... * config/riscv/riscv-builtins.cc: ...here. * config/riscv/riscv-c.c: Moved to... * config/riscv/riscv-c.cc: ...here. * config/riscv/riscv-d.c: Moved to... * config/riscv/riscv-d.cc: ...here. * config/riscv/riscv-shorten-memrefs.c: Moved to... * config/riscv/riscv-shorten-memrefs.cc: ...here. * config/riscv/riscv-sr.c: Moved to... * config/riscv/riscv-sr.cc: ...here. * config/riscv/riscv.c: Moved to... * config/riscv/riscv.cc: ...here. * config/rl78/rl78-c.c: Moved to... * config/rl78/rl78-c.cc: ...here. * config/rl78/rl78.c: Moved to... * config/rl78/rl78.cc: ...here. * config/rs6000/driver-rs6000.c: Moved to... * config/rs6000/driver-rs6000.cc: ...here. * config/rs6000/host-darwin.c: Moved to... * config/rs6000/host-darwin.cc: ...here. * config/rs6000/host-ppc64-darwin.c: Moved to... * config/rs6000/host-ppc64-darwin.cc: ...here. * config/rs6000/rbtree.c: Moved to... * config/rs6000/rbtree.cc: ...here. * config/rs6000/rs6000-c.c: Moved to... * config/rs6000/rs6000-c.cc: ...here. * config/rs6000/rs6000-call.c: Moved to... * config/rs6000/rs6000-call.cc: ...here. * config/rs6000/rs6000-d.c: Moved to... * config/rs6000/rs6000-d.cc: ...here. * config/rs6000/rs6000-gen-builtins.c: Moved to... * config/rs6000/rs6000-gen-builtins.cc: ...here. * config/rs6000/rs6000-linux.c: Moved to... * config/rs6000/rs6000-linux.cc: ...here. * config/rs6000/rs6000-logue.c: Moved to... * config/rs6000/rs6000-logue.cc: ...here. * config/rs6000/rs6000-p8swap.c: Moved to... * config/rs6000/rs6000-p8swap.cc: ...here. * config/rs6000/rs6000-pcrel-opt.c: Moved to... * config/rs6000/rs6000-pcrel-opt.cc: ...here. * config/rs6000/rs6000-string.c: Moved to... * config/rs6000/rs6000-string.cc: ...here. * config/rs6000/rs6000.c: Moved to... * config/rs6000/rs6000.cc: ...here. * config/rx/rx.c: Moved to... * config/rx/rx.cc: ...here. * config/s390/driver-native.c: Moved to... * config/s390/driver-native.cc: ...here. * config/s390/s390-c.c: Moved to... * config/s390/s390-c.cc: ...here. * config/s390/s390-d.c: Moved to... * config/s390/s390-d.cc: ...here. * config/s390/s390.c: Moved to... * config/s390/s390.cc: ...here. * config/sh/divtab-sh4-300.c: Moved to... * config/sh/divtab-sh4-300.cc: ...here. * config/sh/divtab-sh4.c: Moved to... * config/sh/divtab-sh4.cc: ...here. * config/sh/divtab.c: Moved to... * config/sh/divtab.cc: ...here. * config/sh/sh-c.c: Moved to... * config/sh/sh-c.cc: ...here. * config/sh/sh.c: Moved to... * config/sh/sh.cc: ...here. * config/sol2-c.c: Moved to... * config/sol2-c.cc: ...here. * config/sol2-cxx.c: Moved to... * config/sol2-cxx.cc: ...here. * config/sol2-d.c: Moved to... * config/sol2-d.cc: ...here. * config/sol2-stubs.c: Moved to... * config/sol2-stubs.cc: ...here. * config/sol2.c: Moved to... * config/sol2.cc: ...here. * config/sparc/driver-sparc.c: Moved to... * config/sparc/driver-sparc.cc: ...here. * config/sparc/sparc-c.c: Moved to... * config/sparc/sparc-c.cc: ...here. * config/sparc/sparc-d.c: Moved to... * config/sparc/sparc-d.cc: ...here. * config/sparc/sparc.c: Moved to... * config/sparc/sparc.cc: ...here. * config/stormy16/stormy16.c: Moved to... * config/stormy16/stormy16.cc: ...here. * config/tilegx/mul-tables.c: Moved to... * config/tilegx/mul-tables.cc: ...here. * config/tilegx/tilegx-c.c: Moved to... * config/tilegx/tilegx-c.cc: ...here. * config/tilegx/tilegx.c: Moved to... * config/tilegx/tilegx.cc: ...here. * config/tilepro/mul-tables.c: Moved to... * config/tilepro/mul-tables.cc: ...here. * config/tilepro/tilepro-c.c: Moved to... * config/tilepro/tilepro-c.cc: ...here. * config/tilepro/tilepro.c: Moved to... * config/tilepro/tilepro.cc: ...here. * config/v850/v850-c.c: Moved to... * config/v850/v850-c.cc: ...here. * config/v850/v850.c: Moved to... * config/v850/v850.cc: ...here. * config/vax/vax.c: Moved to... * config/vax/vax.cc: ...here. * config/visium/visium.c: Moved to... * config/visium/visium.cc: ...here. * config/vms/vms-c.c: Moved to... * config/vms/vms-c.cc: ...here. * config/vms/vms-f.c: Moved to... * config/vms/vms-f.cc: ...here. * config/vms/vms.c: Moved to... * config/vms/vms.cc: ...here. * config/vxworks-c.c: Moved to... * config/vxworks-c.cc: ...here. * config/vxworks.c: Moved to... * config/vxworks.cc: ...here. * config/winnt-c.c: Moved to... * config/winnt-c.cc: ...here. * config/xtensa/xtensa.c: Moved to... * config/xtensa/xtensa.cc: ...here. * context.c: Moved to... * context.cc: ...here. * convert.c: Moved to... * convert.cc: ...here. * coverage.c: Moved to... * coverage.cc: ...here. * cppbuiltin.c: Moved to... * cppbuiltin.cc: ...here. * cppdefault.c: Moved to... * cppdefault.cc: ...here. * cprop.c: Moved to... * cprop.cc: ...here. * cse.c: Moved to... * cse.cc: ...here. * cselib.c: Moved to... * cselib.cc: ...here. * ctfc.c: Moved to... * ctfc.cc: ...here. * ctfout.c: Moved to... * ctfout.cc: ...here. * data-streamer-in.c: Moved to... * data-streamer-in.cc: ...here. * data-streamer-out.c: Moved to... * data-streamer-out.cc: ...here. * data-streamer.c: Moved to... * data-streamer.cc: ...here. * dbgcnt.c: Moved to... * dbgcnt.cc: ...here. * dbxout.c: Moved to... * dbxout.cc: ...here. * dce.c: Moved to... * dce.cc: ...here. * ddg.c: Moved to... * ddg.cc: ...here. * debug.c: Moved to... * debug.cc: ...here. * df-core.c: Moved to... * df-core.cc: ...here. * df-problems.c: Moved to... * df-problems.cc: ...here. * df-scan.c: Moved to... * df-scan.cc: ...here. * dfp.c: Moved to... * dfp.cc: ...here. * diagnostic-color.c: Moved to... * diagnostic-color.cc: ...here. * diagnostic-show-locus.c: Moved to... * diagnostic-show-locus.cc: ...here. * diagnostic-spec.c: Moved to... * diagnostic-spec.cc: ...here. * diagnostic.c: Moved to... * diagnostic.cc: ...here. * dojump.c: Moved to... * dojump.cc: ...here. * dominance.c: Moved to... * dominance.cc: ...here. * domwalk.c: Moved to... * domwalk.cc: ...here. * double-int.c: Moved to... * double-int.cc: ...here. * dse.c: Moved to... * dse.cc: ...here. * dumpfile.c: Moved to... * dumpfile.cc: ...here. * dwarf2asm.c: Moved to... * dwarf2asm.cc: ...here. * dwarf2cfi.c: Moved to... * dwarf2cfi.cc: ...here. * dwarf2ctf.c: Moved to... * dwarf2ctf.cc: ...here. * dwarf2out.c: Moved to... * dwarf2out.cc: ...here. * early-remat.c: Moved to... * early-remat.cc: ...here. * edit-context.c: Moved to... * edit-context.cc: ...here. * emit-rtl.c: Moved to... * emit-rtl.cc: ...here. * errors.c: Moved to... * errors.cc: ...here. * et-forest.c: Moved to... * et-forest.cc: ...here. * except.c: Moved to... * except.cc: ...here. * explow.c: Moved to... * explow.cc: ...here. * expmed.c: Moved to... * expmed.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * fibonacci_heap.c: Moved to... * fibonacci_heap.cc: ...here. * file-find.c: Moved to... * file-find.cc: ...here. * file-prefix-map.c: Moved to... * file-prefix-map.cc: ...here. * final.c: Moved to... * final.cc: ...here. * fixed-value.c: Moved to... * fixed-value.cc: ...here. * fold-const-call.c: Moved to... * fold-const-call.cc: ...here. * fold-const.c: Moved to... * fold-const.cc: ...here. * fp-test.c: Moved to... * fp-test.cc: ...here. * function-tests.c: Moved to... * function-tests.cc: ...here. * function.c: Moved to... * function.cc: ...here. * fwprop.c: Moved to... * fwprop.cc: ...here. * gcc-ar.c: Moved to... * gcc-ar.cc: ...here. * gcc-main.c: Moved to... * gcc-main.cc: ...here. * gcc-rich-location.c: Moved to... * gcc-rich-location.cc: ...here. * gcc.c: Moved to... * gcc.cc: ...here. * gcov-dump.c: Moved to... * gcov-dump.cc: ...here. * gcov-io.c: Moved to... * gcov-io.cc: ...here. * gcov-tool.c: Moved to... * gcov-tool.cc: ...here. * gcov.c: Moved to... * gcov.cc: ...here. * gcse-common.c: Moved to... * gcse-common.cc: ...here. * gcse.c: Moved to... * gcse.cc: ...here. * genattr-common.c: Moved to... * genattr-common.cc: ...here. * genattr.c: Moved to... * genattr.cc: ...here. * genattrtab.c: Moved to... * genattrtab.cc: ...here. * genautomata.c: Moved to... * genautomata.cc: ...here. * gencfn-macros.c: Moved to... * gencfn-macros.cc: ...here. * gencheck.c: Moved to... * gencheck.cc: ...here. * genchecksum.c: Moved to... * genchecksum.cc: ...here. * gencodes.c: Moved to... * gencodes.cc: ...here. * genconditions.c: Moved to... * genconditions.cc: ...here. * genconfig.c: Moved to... * genconfig.cc: ...here. * genconstants.c: Moved to... * genconstants.cc: ...here. * genemit.c: Moved to... * genemit.cc: ...here. * genenums.c: Moved to... * genenums.cc: ...here. * generic-match-head.c: Moved to... * generic-match-head.cc: ...here. * genextract.c: Moved to... * genextract.cc: ...here. * genflags.c: Moved to... * genflags.cc: ...here. * gengenrtl.c: Moved to... * gengenrtl.cc: ...here. * gengtype-parse.c: Moved to... * gengtype-parse.cc: ...here. * gengtype-state.c: Moved to... * gengtype-state.cc: ...here. * gengtype.c: Moved to... * gengtype.cc: ...here. * genhooks.c: Moved to... * genhooks.cc: ...here. * genmatch.c: Moved to... * genmatch.cc: ...here. * genmddeps.c: Moved to... * genmddeps.cc: ...here. * genmddump.c: Moved to... * genmddump.cc: ...here. * genmodes.c: Moved to... * genmodes.cc: ...here. * genopinit.c: Moved to... * genopinit.cc: ...here. * genoutput.c: Moved to... * genoutput.cc: ...here. * genpeep.c: Moved to... * genpeep.cc: ...here. * genpreds.c: Moved to... * genpreds.cc: ...here. * genrecog.c: Moved to... * genrecog.cc: ...here. * gensupport.c: Moved to... * gensupport.cc: ...here. * gentarget-def.c: Moved to... * gentarget-def.cc: ...here. * genversion.c: Moved to... * genversion.cc: ...here. * ggc-common.c: Moved to... * ggc-common.cc: ...here. * ggc-none.c: Moved to... * ggc-none.cc: ...here. * ggc-page.c: Moved to... * ggc-page.cc: ...here. * ggc-tests.c: Moved to... * ggc-tests.cc: ...here. * gimple-builder.c: Moved to... * gimple-builder.cc: ...here. * gimple-expr.c: Moved to... * gimple-expr.cc: ...here. * gimple-fold.c: Moved to... * gimple-fold.cc: ...here. * gimple-iterator.c: Moved to... * gimple-iterator.cc: ...here. * gimple-laddress.c: Moved to... * gimple-laddress.cc: ...here. * gimple-loop-jam.c: Moved to... * gimple-loop-jam.cc: ...here. * gimple-low.c: Moved to... * gimple-low.cc: ...here. * gimple-match-head.c: Moved to... * gimple-match-head.cc: ...here. * gimple-pretty-print.c: Moved to... * gimple-pretty-print.cc: ...here. * gimple-ssa-backprop.c: Moved to... * gimple-ssa-backprop.cc: ...here. * gimple-ssa-evrp-analyze.c: Moved to... * gimple-ssa-evrp-analyze.cc: ...here. * gimple-ssa-evrp.c: Moved to... * gimple-ssa-evrp.cc: ...here. * gimple-ssa-isolate-paths.c: Moved to... * gimple-ssa-isolate-paths.cc: ...here. * gimple-ssa-nonnull-compare.c: Moved to... * gimple-ssa-nonnull-compare.cc: ...here. * gimple-ssa-split-paths.c: Moved to... * gimple-ssa-split-paths.cc: ...here. * gimple-ssa-sprintf.c: Moved to... * gimple-ssa-sprintf.cc: ...here. * gimple-ssa-store-merging.c: Moved to... * gimple-ssa-store-merging.cc: ...here. * gimple-ssa-strength-reduction.c: Moved to... * gimple-ssa-strength-reduction.cc: ...here. * gimple-ssa-warn-alloca.c: Moved to... * gimple-ssa-warn-alloca.cc: ...here. * gimple-ssa-warn-restrict.c: Moved to... * gimple-ssa-warn-restrict.cc: ...here. * gimple-streamer-in.c: Moved to... * gimple-streamer-in.cc: ...here. * gimple-streamer-out.c: Moved to... * gimple-streamer-out.cc: ...here. * gimple-walk.c: Moved to... * gimple-walk.cc: ...here. * gimple-warn-recursion.c: Moved to... * gimple-warn-recursion.cc: ...here. * gimple.c: Moved to... * gimple.cc: ...here. * gimplify-me.c: Moved to... * gimplify-me.cc: ...here. * gimplify.c: Moved to... * gimplify.cc: ...here. * godump.c: Moved to... * godump.cc: ...here. * graph.c: Moved to... * graph.cc: ...here. * graphds.c: Moved to... * graphds.cc: ...here. * graphite-dependences.c: Moved to... * graphite-dependences.cc: ...here. * graphite-isl-ast-to-gimple.c: Moved to... * graphite-isl-ast-to-gimple.cc: ...here. * graphite-optimize-isl.c: Moved to... * graphite-optimize-isl.cc: ...here. * graphite-poly.c: Moved to... * graphite-poly.cc: ...here. * graphite-scop-detection.c: Moved to... * graphite-scop-detection.cc: ...here. * graphite-sese-to-poly.c: Moved to... * graphite-sese-to-poly.cc: ...here. * graphite.c: Moved to... * graphite.cc: ...here. * haifa-sched.c: Moved to... * haifa-sched.cc: ...here. * hash-map-tests.c: Moved to... * hash-map-tests.cc: ...here. * hash-set-tests.c: Moved to... * hash-set-tests.cc: ...here. * hash-table.c: Moved to... * hash-table.cc: ...here. * hooks.c: Moved to... * hooks.cc: ...here. * host-default.c: Moved to... * host-default.cc: ...here. * hw-doloop.c: Moved to... * hw-doloop.cc: ...here. * hwint.c: Moved to... * hwint.cc: ...here. * ifcvt.c: Moved to... * ifcvt.cc: ...here. * inchash.c: Moved to... * inchash.cc: ...here. * incpath.c: Moved to... * incpath.cc: ...here. * init-regs.c: Moved to... * init-regs.cc: ...here. * input.c: Moved to... * input.cc: ...here. * internal-fn.c: Moved to... * internal-fn.cc: ...here. * intl.c: Moved to... * intl.cc: ...here. * ipa-comdats.c: Moved to... * ipa-comdats.cc: ...here. * ipa-cp.c: Moved to... * ipa-cp.cc: ...here. * ipa-devirt.c: Moved to... * ipa-devirt.cc: ...here. * ipa-fnsummary.c: Moved to... * ipa-fnsummary.cc: ...here. * ipa-icf-gimple.c: Moved to... * ipa-icf-gimple.cc: ...here. * ipa-icf.c: Moved to... * ipa-icf.cc: ...here. * ipa-inline-analysis.c: Moved to... * ipa-inline-analysis.cc: ...here. * ipa-inline-transform.c: Moved to... * ipa-inline-transform.cc: ...here. * ipa-inline.c: Moved to... * ipa-inline.cc: ...here. * ipa-modref-tree.c: Moved to... * ipa-modref-tree.cc: ...here. * ipa-modref.c: Moved to... * ipa-modref.cc: ...here. * ipa-param-manipulation.c: Moved to... * ipa-param-manipulation.cc: ...here. * ipa-polymorphic-call.c: Moved to... * ipa-polymorphic-call.cc: ...here. * ipa-predicate.c: Moved to... * ipa-predicate.cc: ...here. * ipa-profile.c: Moved to... * ipa-profile.cc: ...here. * ipa-prop.c: Moved to... * ipa-prop.cc: ...here. * ipa-pure-const.c: Moved to... * ipa-pure-const.cc: ...here. * ipa-ref.c: Moved to... * ipa-ref.cc: ...here. * ipa-reference.c: Moved to... * ipa-reference.cc: ...here. * ipa-split.c: Moved to... * ipa-split.cc: ...here. * ipa-sra.c: Moved to... * ipa-sra.cc: ...here. * ipa-utils.c: Moved to... * ipa-utils.cc: ...here. * ipa-visibility.c: Moved to... * ipa-visibility.cc: ...here. * ipa.c: Moved to... * ipa.cc: ...here. * ira-build.c: Moved to... * ira-build.cc: ...here. * ira-color.c: Moved to... * ira-color.cc: ...here. * ira-conflicts.c: Moved to... * ira-conflicts.cc: ...here. * ira-costs.c: Moved to... * ira-costs.cc: ...here. * ira-emit.c: Moved to... * ira-emit.cc: ...here. * ira-lives.c: Moved to... * ira-lives.cc: ...here. * ira.c: Moved to... * ira.cc: ...here. * jump.c: Moved to... * jump.cc: ...here. * langhooks.c: Moved to... * langhooks.cc: ...here. * lcm.c: Moved to... * lcm.cc: ...here. * lists.c: Moved to... * lists.cc: ...here. * loop-doloop.c: Moved to... * loop-doloop.cc: ...here. * loop-init.c: Moved to... * loop-init.cc: ...here. * loop-invariant.c: Moved to... * loop-invariant.cc: ...here. * loop-iv.c: Moved to... * loop-iv.cc: ...here. * loop-unroll.c: Moved to... * loop-unroll.cc: ...here. * lower-subreg.c: Moved to... * lower-subreg.cc: ...here. * lra-assigns.c: Moved to... * lra-assigns.cc: ...here. * lra-coalesce.c: Moved to... * lra-coalesce.cc: ...here. * lra-constraints.c: Moved to... * lra-constraints.cc: ...here. * lra-eliminations.c: Moved to... * lra-eliminations.cc: ...here. * lra-lives.c: Moved to... * lra-lives.cc: ...here. * lra-remat.c: Moved to... * lra-remat.cc: ...here. * lra-spills.c: Moved to... * lra-spills.cc: ...here. * lra.c: Moved to... * lra.cc: ...here. * lto-cgraph.c: Moved to... * lto-cgraph.cc: ...here. * lto-compress.c: Moved to... * lto-compress.cc: ...here. * lto-opts.c: Moved to... * lto-opts.cc: ...here. * lto-section-in.c: Moved to... * lto-section-in.cc: ...here. * lto-section-out.c: Moved to... * lto-section-out.cc: ...here. * lto-streamer-in.c: Moved to... * lto-streamer-in.cc: ...here. * lto-streamer-out.c: Moved to... * lto-streamer-out.cc: ...here. * lto-streamer.c: Moved to... * lto-streamer.cc: ...here. * lto-wrapper.c: Moved to... * lto-wrapper.cc: ...here. * main.c: Moved to... * main.cc: ...here. * mcf.c: Moved to... * mcf.cc: ...here. * mode-switching.c: Moved to... * mode-switching.cc: ...here. * modulo-sched.c: Moved to... * modulo-sched.cc: ...here. * multiple_target.c: Moved to... * multiple_target.cc: ...here. * omp-expand.c: Moved to... * omp-expand.cc: ...here. * omp-general.c: Moved to... * omp-general.cc: ...here. * omp-low.c: Moved to... * omp-low.cc: ...here. * omp-offload.c: Moved to... * omp-offload.cc: ...here. * omp-simd-clone.c: Moved to... * omp-simd-clone.cc: ...here. * opt-suggestions.c: Moved to... * opt-suggestions.cc: ...here. * optabs-libfuncs.c: Moved to... * optabs-libfuncs.cc: ...here. * optabs-query.c: Moved to... * optabs-query.cc: ...here. * optabs-tree.c: Moved to... * optabs-tree.cc: ...here. * optabs.c: Moved to... * optabs.cc: ...here. * opts-common.c: Moved to... * opts-common.cc: ...here. * opts-global.c: Moved to... * opts-global.cc: ...here. * opts.c: Moved to... * opts.cc: ...here. * passes.c: Moved to... * passes.cc: ...here. * plugin.c: Moved to... * plugin.cc: ...here. * postreload-gcse.c: Moved to... * postreload-gcse.cc: ...here. * postreload.c: Moved to... * postreload.cc: ...here. * predict.c: Moved to... * predict.cc: ...here. * prefix.c: Moved to... * prefix.cc: ...here. * pretty-print.c: Moved to... * pretty-print.cc: ...here. * print-rtl-function.c: Moved to... * print-rtl-function.cc: ...here. * print-rtl.c: Moved to... * print-rtl.cc: ...here. * print-tree.c: Moved to... * print-tree.cc: ...here. * profile-count.c: Moved to... * profile-count.cc: ...here. * profile.c: Moved to... * profile.cc: ...here. * read-md.c: Moved to... * read-md.cc: ...here. * read-rtl-function.c: Moved to... * read-rtl-function.cc: ...here. * read-rtl.c: Moved to... * read-rtl.cc: ...here. * real.c: Moved to... * real.cc: ...here. * realmpfr.c: Moved to... * realmpfr.cc: ...here. * recog.c: Moved to... * recog.cc: ...here. * ree.c: Moved to... * ree.cc: ...here. * reg-stack.c: Moved to... * reg-stack.cc: ...here. * regcprop.c: Moved to... * regcprop.cc: ...here. * reginfo.c: Moved to... * reginfo.cc: ...here. * regrename.c: Moved to... * regrename.cc: ...here. * regstat.c: Moved to... * regstat.cc: ...here. * reload.c: Moved to... * reload.cc: ...here. * reload1.c: Moved to... * reload1.cc: ...here. * reorg.c: Moved to... * reorg.cc: ...here. * resource.c: Moved to... * resource.cc: ...here. * rtl-error.c: Moved to... * rtl-error.cc: ...here. * rtl-tests.c: Moved to... * rtl-tests.cc: ...here. * rtl.c: Moved to... * rtl.cc: ...here. * rtlanal.c: Moved to... * rtlanal.cc: ...here. * rtlhash.c: Moved to... * rtlhash.cc: ...here. * rtlhooks.c: Moved to... * rtlhooks.cc: ...here. * rtx-vector-builder.c: Moved to... * rtx-vector-builder.cc: ...here. * run-rtl-passes.c: Moved to... * run-rtl-passes.cc: ...here. * sancov.c: Moved to... * sancov.cc: ...here. * sanopt.c: Moved to... * sanopt.cc: ...here. * sbitmap.c: Moved to... * sbitmap.cc: ...here. * sched-deps.c: Moved to... * sched-deps.cc: ...here. * sched-ebb.c: Moved to... * sched-ebb.cc: ...here. * sched-rgn.c: Moved to... * sched-rgn.cc: ...here. * sel-sched-dump.c: Moved to... * sel-sched-dump.cc: ...here. * sel-sched-ir.c: Moved to... * sel-sched-ir.cc: ...here. * sel-sched.c: Moved to... * sel-sched.cc: ...here. * selftest-diagnostic.c: Moved to... * selftest-diagnostic.cc: ...here. * selftest-rtl.c: Moved to... * selftest-rtl.cc: ...here. * selftest-run-tests.c: Moved to... * selftest-run-tests.cc: ...here. * selftest.c: Moved to... * selftest.cc: ...here. * sese.c: Moved to... * sese.cc: ...here. * shrink-wrap.c: Moved to... * shrink-wrap.cc: ...here. * simplify-rtx.c: Moved to... * simplify-rtx.cc: ...here. * sparseset.c: Moved to... * sparseset.cc: ...here. * spellcheck-tree.c: Moved to... * spellcheck-tree.cc: ...here. * spellcheck.c: Moved to... * spellcheck.cc: ...here. * sreal.c: Moved to... * sreal.cc: ...here. * stack-ptr-mod.c: Moved to... * stack-ptr-mod.cc: ...here. * statistics.c: Moved to... * statistics.cc: ...here. * stmt.c: Moved to... * stmt.cc: ...here. * stor-layout.c: Moved to... * stor-layout.cc: ...here. * store-motion.c: Moved to... * store-motion.cc: ...here. * streamer-hooks.c: Moved to... * streamer-hooks.cc: ...here. * stringpool.c: Moved to... * stringpool.cc: ...here. * substring-locations.c: Moved to... * substring-locations.cc: ...here. * symtab.c: Moved to... * symtab.cc: ...here. * target-globals.c: Moved to... * target-globals.cc: ...here. * targhooks.c: Moved to... * targhooks.cc: ...here. * timevar.c: Moved to... * timevar.cc: ...here. * toplev.c: Moved to... * toplev.cc: ...here. * tracer.c: Moved to... * tracer.cc: ...here. * trans-mem.c: Moved to... * trans-mem.cc: ...here. * tree-affine.c: Moved to... * tree-affine.cc: ...here. * tree-call-cdce.c: Moved to... * tree-call-cdce.cc: ...here. * tree-cfg.c: Moved to... * tree-cfg.cc: ...here. * tree-cfgcleanup.c: Moved to... * tree-cfgcleanup.cc: ...here. * tree-chrec.c: Moved to... * tree-chrec.cc: ...here. * tree-complex.c: Moved to... * tree-complex.cc: ...here. * tree-data-ref.c: Moved to... * tree-data-ref.cc: ...here. * tree-dfa.c: Moved to... * tree-dfa.cc: ...here. * tree-diagnostic.c: Moved to... * tree-diagnostic.cc: ...here. * tree-dump.c: Moved to... * tree-dump.cc: ...here. * tree-eh.c: Moved to... * tree-eh.cc: ...here. * tree-emutls.c: Moved to... * tree-emutls.cc: ...here. * tree-if-conv.c: Moved to... * tree-if-conv.cc: ...here. * tree-inline.c: Moved to... * tree-inline.cc: ...here. * tree-into-ssa.c: Moved to... * tree-into-ssa.cc: ...here. * tree-iterator.c: Moved to... * tree-iterator.cc: ...here. * tree-loop-distribution.c: Moved to... * tree-loop-distribution.cc: ...here. * tree-nested.c: Moved to... * tree-nested.cc: ...here. * tree-nrv.c: Moved to... * tree-nrv.cc: ...here. * tree-object-size.c: Moved to... * tree-object-size.cc: ...here. * tree-outof-ssa.c: Moved to... * tree-outof-ssa.cc: ...here. * tree-parloops.c: Moved to... * tree-parloops.cc: ...here. * tree-phinodes.c: Moved to... * tree-phinodes.cc: ...here. * tree-predcom.c: Moved to... * tree-predcom.cc: ...here. * tree-pretty-print.c: Moved to... * tree-pretty-print.cc: ...here. * tree-profile.c: Moved to... * tree-profile.cc: ...here. * tree-scalar-evolution.c: Moved to... * tree-scalar-evolution.cc: ...here. * tree-sra.c: Moved to... * tree-sra.cc: ...here. * tree-ssa-address.c: Moved to... * tree-ssa-address.cc: ...here. * tree-ssa-alias.c: Moved to... * tree-ssa-alias.cc: ...here. * tree-ssa-ccp.c: Moved to... * tree-ssa-ccp.cc: ...here. * tree-ssa-coalesce.c: Moved to... * tree-ssa-coalesce.cc: ...here. * tree-ssa-copy.c: Moved to... * tree-ssa-copy.cc: ...here. * tree-ssa-dce.c: Moved to... * tree-ssa-dce.cc: ...here. * tree-ssa-dom.c: Moved to... * tree-ssa-dom.cc: ...here. * tree-ssa-dse.c: Moved to... * tree-ssa-dse.cc: ...here. * tree-ssa-forwprop.c: Moved to... * tree-ssa-forwprop.cc: ...here. * tree-ssa-ifcombine.c: Moved to... * tree-ssa-ifcombine.cc: ...here. * tree-ssa-live.c: Moved to... * tree-ssa-live.cc: ...here. * tree-ssa-loop-ch.c: Moved to... * tree-ssa-loop-ch.cc: ...here. * tree-ssa-loop-im.c: Moved to... * tree-ssa-loop-im.cc: ...here. * tree-ssa-loop-ivcanon.c: Moved to... * tree-ssa-loop-ivcanon.cc: ...here. * tree-ssa-loop-ivopts.c: Moved to... * tree-ssa-loop-ivopts.cc: ...here. * tree-ssa-loop-manip.c: Moved to... * tree-ssa-loop-manip.cc: ...here. * tree-ssa-loop-niter.c: Moved to... * tree-ssa-loop-niter.cc: ...here. * tree-ssa-loop-prefetch.c: Moved to... * tree-ssa-loop-prefetch.cc: ...here. * tree-ssa-loop-split.c: Moved to... * tree-ssa-loop-split.cc: ...here. * tree-ssa-loop-unswitch.c: Moved to... * tree-ssa-loop-unswitch.cc: ...here. * tree-ssa-loop.c: Moved to... * tree-ssa-loop.cc: ...here. * tree-ssa-math-opts.c: Moved to... * tree-ssa-math-opts.cc: ...here. * tree-ssa-operands.c: Moved to... * tree-ssa-operands.cc: ...here. * tree-ssa-phiopt.c: Moved to... * tree-ssa-phiopt.cc: ...here. * tree-ssa-phiprop.c: Moved to... * tree-ssa-phiprop.cc: ...here. * tree-ssa-pre.c: Moved to... * tree-ssa-pre.cc: ...here. * tree-ssa-propagate.c: Moved to... * tree-ssa-propagate.cc: ...here. * tree-ssa-reassoc.c: Moved to... * tree-ssa-reassoc.cc: ...here. * tree-ssa-sccvn.c: Moved to... * tree-ssa-sccvn.cc: ...here. * tree-ssa-scopedtables.c: Moved to... * tree-ssa-scopedtables.cc: ...here. * tree-ssa-sink.c: Moved to... * tree-ssa-sink.cc: ...here. * tree-ssa-strlen.c: Moved to... * tree-ssa-strlen.cc: ...here. * tree-ssa-structalias.c: Moved to... * tree-ssa-structalias.cc: ...here. * tree-ssa-tail-merge.c: Moved to... * tree-ssa-tail-merge.cc: ...here. * tree-ssa-ter.c: Moved to... * tree-ssa-ter.cc: ...here. * tree-ssa-threadbackward.c: Moved to... * tree-ssa-threadbackward.cc: ...here. * tree-ssa-threadedge.c: Moved to... * tree-ssa-threadedge.cc: ...here. * tree-ssa-threadupdate.c: Moved to... * tree-ssa-threadupdate.cc: ...here. * tree-ssa-uncprop.c: Moved to... * tree-ssa-uncprop.cc: ...here. * tree-ssa-uninit.c: Moved to... * tree-ssa-uninit.cc: ...here. * tree-ssa.c: Moved to... * tree-ssa.cc: ...here. * tree-ssanames.c: Moved to... * tree-ssanames.cc: ...here. * tree-stdarg.c: Moved to... * tree-stdarg.cc: ...here. * tree-streamer-in.c: Moved to... * tree-streamer-in.cc: ...here. * tree-streamer-out.c: Moved to... * tree-streamer-out.cc: ...here. * tree-streamer.c: Moved to... * tree-streamer.cc: ...here. * tree-switch-conversion.c: Moved to... * tree-switch-conversion.cc: ...here. * tree-tailcall.c: Moved to... * tree-tailcall.cc: ...here. * tree-vect-data-refs.c: Moved to... * tree-vect-data-refs.cc: ...here. * tree-vect-generic.c: Moved to... * tree-vect-generic.cc: ...here. * tree-vect-loop-manip.c: Moved to... * tree-vect-loop-manip.cc: ...here. * tree-vect-loop.c: Moved to... * tree-vect-loop.cc: ...here. * tree-vect-patterns.c: Moved to... * tree-vect-patterns.cc: ...here. * tree-vect-slp-patterns.c: Moved to... * tree-vect-slp-patterns.cc: ...here. * tree-vect-slp.c: Moved to... * tree-vect-slp.cc: ...here. * tree-vect-stmts.c: Moved to... * tree-vect-stmts.cc: ...here. * tree-vector-builder.c: Moved to... * tree-vector-builder.cc: ...here. * tree-vectorizer.c: Moved to... * tree-vectorizer.cc: ...here. * tree-vrp.c: Moved to... * tree-vrp.cc: ...here. * tree.c: Moved to... * tree.cc: ...here. * tsan.c: Moved to... * tsan.cc: ...here. * typed-splay-tree.c: Moved to... * typed-splay-tree.cc: ...here. * ubsan.c: Moved to... * ubsan.cc: ...here. * valtrack.c: Moved to... * valtrack.cc: ...here. * value-prof.c: Moved to... * value-prof.cc: ...here. * var-tracking.c: Moved to... * var-tracking.cc: ...here. * varasm.c: Moved to... * varasm.cc: ...here. * varpool.c: Moved to... * varpool.cc: ...here. * vec-perm-indices.c: Moved to... * vec-perm-indices.cc: ...here. * vec.c: Moved to... * vec.cc: ...here. * vmsdbgout.c: Moved to... * vmsdbgout.cc: ...here. * vr-values.c: Moved to... * vr-values.cc: ...here. * vtable-verify.c: Moved to... * vtable-verify.cc: ...here. * web.c: Moved to... * web.cc: ...here. * xcoffout.c: Moved to... * xcoffout.cc: ...here. gcc/c-family/ChangeLog: * c-ada-spec.c: Moved to... * c-ada-spec.cc: ...here. * c-attribs.c: Moved to... * c-attribs.cc: ...here. * c-common.c: Moved to... * c-common.cc: ...here. * c-cppbuiltin.c: Moved to... * c-cppbuiltin.cc: ...here. * c-dump.c: Moved to... * c-dump.cc: ...here. * c-format.c: Moved to... * c-format.cc: ...here. * c-gimplify.c: Moved to... * c-gimplify.cc: ...here. * c-indentation.c: Moved to... * c-indentation.cc: ...here. * c-lex.c: Moved to... * c-lex.cc: ...here. * c-omp.c: Moved to... * c-omp.cc: ...here. * c-opts.c: Moved to... * c-opts.cc: ...here. * c-pch.c: Moved to... * c-pch.cc: ...here. * c-ppoutput.c: Moved to... * c-ppoutput.cc: ...here. * c-pragma.c: Moved to... * c-pragma.cc: ...here. * c-pretty-print.c: Moved to... * c-pretty-print.cc: ...here. * c-semantics.c: Moved to... * c-semantics.cc: ...here. * c-ubsan.c: Moved to... * c-ubsan.cc: ...here. * c-warn.c: Moved to... * c-warn.cc: ...here. * cppspec.c: Moved to... * cppspec.cc: ...here. * stub-objc.c: Moved to... * stub-objc.cc: ...here. gcc/c/ChangeLog: * c-aux-info.c: Moved to... * c-aux-info.cc: ...here. * c-convert.c: Moved to... * c-convert.cc: ...here. * c-decl.c: Moved to... * c-decl.cc: ...here. * c-errors.c: Moved to... * c-errors.cc: ...here. * c-fold.c: Moved to... * c-fold.cc: ...here. * c-lang.c: Moved to... * c-lang.cc: ...here. * c-objc-common.c: Moved to... * c-objc-common.cc: ...here. * c-parser.c: Moved to... * c-parser.cc: ...here. * c-typeck.c: Moved to... * c-typeck.cc: ...here. * gccspec.c: Moved to... * gccspec.cc: ...here. * gimple-parser.c: Moved to... * gimple-parser.cc: ...here. gcc/cp/ChangeLog: * call.c: Moved to... * call.cc: ...here. * class.c: Moved to... * class.cc: ...here. * constexpr.c: Moved to... * constexpr.cc: ...here. * cp-gimplify.c: Moved to... * cp-gimplify.cc: ...here. * cp-lang.c: Moved to... * cp-lang.cc: ...here. * cp-objcp-common.c: Moved to... * cp-objcp-common.cc: ...here. * cp-ubsan.c: Moved to... * cp-ubsan.cc: ...here. * cvt.c: Moved to... * cvt.cc: ...here. * cxx-pretty-print.c: Moved to... * cxx-pretty-print.cc: ...here. * decl.c: Moved to... * decl.cc: ...here. * decl2.c: Moved to... * decl2.cc: ...here. * dump.c: Moved to... * dump.cc: ...here. * error.c: Moved to... * error.cc: ...here. * except.c: Moved to... * except.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * friend.c: Moved to... * friend.cc: ...here. * g++spec.c: Moved to... * g++spec.cc: ...here. * init.c: Moved to... * init.cc: ...here. * lambda.c: Moved to... * lambda.cc: ...here. * lex.c: Moved to... * lex.cc: ...here. * mangle.c: Moved to... * mangle.cc: ...here. * method.c: Moved to... * method.cc: ...here. * name-lookup.c: Moved to... * name-lookup.cc: ...here. * optimize.c: Moved to... * optimize.cc: ...here. * parser.c: Moved to... * parser.cc: ...here. * pt.c: Moved to... * pt.cc: ...here. * ptree.c: Moved to... * ptree.cc: ...here. * rtti.c: Moved to... * rtti.cc: ...here. * search.c: Moved to... * search.cc: ...here. * semantics.c: Moved to... * semantics.cc: ...here. * tree.c: Moved to... * tree.cc: ...here. * typeck.c: Moved to... * typeck.cc: ...here. * typeck2.c: Moved to... * typeck2.cc: ...here. * vtable-class-hierarchy.c: Moved to... * vtable-class-hierarchy.cc: ...here. gcc/fortran/ChangeLog: * arith.c: Moved to... * arith.cc: ...here. * array.c: Moved to... * array.cc: ...here. * bbt.c: Moved to... * bbt.cc: ...here. * check.c: Moved to... * check.cc: ...here. * class.c: Moved to... * class.cc: ...here. * constructor.c: Moved to... * constructor.cc: ...here. * convert.c: Moved to... * convert.cc: ...here. * cpp.c: Moved to... * cpp.cc: ...here. * data.c: Moved to... * data.cc: ...here. * decl.c: Moved to... * decl.cc: ...here. * dependency.c: Moved to... * dependency.cc: ...here. * dump-parse-tree.c: Moved to... * dump-parse-tree.cc: ...here. * error.c: Moved to... * error.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * f95-lang.c: Moved to... * f95-lang.cc: ...here. * frontend-passes.c: Moved to... * frontend-passes.cc: ...here. * gfortranspec.c: Moved to... * gfortranspec.cc: ...here. * interface.c: Moved to... * interface.cc: ...here. * intrinsic.c: Moved to... * intrinsic.cc: ...here. * io.c: Moved to... * io.cc: ...here. * iresolve.c: Moved to... * iresolve.cc: ...here. * match.c: Moved to... * match.cc: ...here. * matchexp.c: Moved to... * matchexp.cc: ...here. * misc.c: Moved to... * misc.cc: ...here. * module.c: Moved to... * module.cc: ...here. * openmp.c: Moved to... * openmp.cc: ...here. * options.c: Moved to... * options.cc: ...here. * parse.c: Moved to... * parse.cc: ...here. * primary.c: Moved to... * primary.cc: ...here. * resolve.c: Moved to... * resolve.cc: ...here. * scanner.c: Moved to... * scanner.cc: ...here. * simplify.c: Moved to... * simplify.cc: ...here. * st.c: Moved to... * st.cc: ...here. * symbol.c: Moved to... * symbol.cc: ...here. * target-memory.c: Moved to... * target-memory.cc: ...here. * trans-array.c: Moved to... * trans-array.cc: ...here. * trans-common.c: Moved to... * trans-common.cc: ...here. * trans-const.c: Moved to... * trans-const.cc: ...here. * trans-decl.c: Moved to... * trans-decl.cc: ...here. * trans-expr.c: Moved to... * trans-expr.cc: ...here. * trans-intrinsic.c: Moved to... * trans-intrinsic.cc: ...here. * trans-io.c: Moved to... * trans-io.cc: ...here. * trans-openmp.c: Moved to... * trans-openmp.cc: ...here. * trans-stmt.c: Moved to... * trans-stmt.cc: ...here. * trans-types.c: Moved to... * trans-types.cc: ...here. * trans.c: Moved to... * trans.cc: ...here. gcc/go/ChangeLog: * go-backend.c: Moved to... * go-backend.cc: ...here. * go-lang.c: Moved to... * go-lang.cc: ...here. * gospec.c: Moved to... * gospec.cc: ...here. gcc/jit/ChangeLog: * dummy-frontend.c: Moved to... * dummy-frontend.cc: ...here. * jit-builtins.c: Moved to... * jit-builtins.cc: ...here. * jit-logging.c: Moved to... * jit-logging.cc: ...here. * jit-playback.c: Moved to... * jit-playback.cc: ...here. * jit-recording.c: Moved to... * jit-recording.cc: ...here. * jit-result.c: Moved to... * jit-result.cc: ...here. * jit-spec.c: Moved to... * jit-spec.cc: ...here. * jit-tempdir.c: Moved to... * jit-tempdir.cc: ...here. * jit-w32.c: Moved to... * jit-w32.cc: ...here. * libgccjit.c: Moved to... * libgccjit.cc: ...here. gcc/lto/ChangeLog: * common.c: Moved to... * common.cc: ...here. * lto-common.c: Moved to... * lto-common.cc: ...here. * lto-dump.c: Moved to... * lto-dump.cc: ...here. * lto-lang.c: Moved to... * lto-lang.cc: ...here. * lto-object.c: Moved to... * lto-object.cc: ...here. * lto-partition.c: Moved to... * lto-partition.cc: ...here. * lto-symtab.c: Moved to... * lto-symtab.cc: ...here. * lto.c: Moved to... * lto.cc: ...here. gcc/objc/ChangeLog: * objc-act.c: Moved to... * objc-act.cc: ...here. * objc-encoding.c: Moved to... * objc-encoding.cc: ...here. * objc-gnu-runtime-abi-01.c: Moved to... * objc-gnu-runtime-abi-01.cc: ...here. * objc-lang.c: Moved to... * objc-lang.cc: ...here. * objc-map.c: Moved to... * objc-map.cc: ...here. * objc-next-runtime-abi-01.c: Moved to... * objc-next-runtime-abi-01.cc: ...here. * objc-next-runtime-abi-02.c: Moved to... * objc-next-runtime-abi-02.cc: ...here. * objc-runtime-shared-support.c: Moved to... * objc-runtime-shared-support.cc: ...here. gcc/objcp/ChangeLog: * objcp-decl.c: Moved to... * objcp-decl.cc: ...here. * objcp-lang.c: Moved to... * objcp-lang.cc: ...here. libcpp/ChangeLog: * charset.c: Moved to... * charset.cc: ...here. * directives.c: Moved to... * directives.cc: ...here. * errors.c: Moved to... * errors.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * files.c: Moved to... * files.cc: ...here. * identifiers.c: Moved to... * identifiers.cc: ...here. * init.c: Moved to... * init.cc: ...here. * lex.c: Moved to... * lex.cc: ...here. * line-map.c: Moved to... * line-map.cc: ...here. * macro.c: Moved to... * macro.cc: ...here. * makeucnid.c: Moved to... * makeucnid.cc: ...here. * mkdeps.c: Moved to... * mkdeps.cc: ...here. * pch.c: Moved to... * pch.cc: ...here. * symtab.c: Moved to... * symtab.cc: ...here. * traditional.c: Moved to... * traditional.cc: ...here.
Diffstat (limited to 'gcc/fortran/frontend-passes.c')
-rw-r--r--gcc/fortran/frontend-passes.c5951
1 files changed, 0 insertions, 5951 deletions
diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
deleted file mode 100644
index 22f1bb5..0000000
--- a/gcc/fortran/frontend-passes.c
+++ /dev/null
@@ -1,5951 +0,0 @@
-/* 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-08-09 17:15:37 +0000