aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/trans-expr.c
diff options
context:
space:
mode:
authorMartin Liska <mliska@suse.cz>2022-01-14 16:56:44 +0100
committerMartin Liska <mliska@suse.cz>2022-01-17 22:12:04 +0100
commit5c69acb32329d49e58c26fa41ae74229a52b9106 (patch)
treeddb05f9d73afb6f998457d2ac4b720e3b3b60483 /gcc/fortran/trans-expr.c
parent490e23032baaece71f2ec09fa1805064b150fbc2 (diff)
downloadgcc-5c69acb32329d49e58c26fa41ae74229a52b9106.zip
gcc-5c69acb32329d49e58c26fa41ae74229a52b9106.tar.gz
gcc-5c69acb32329d49e58c26fa41ae74229a52b9106.tar.bz2
Rename .c files to .cc files.
gcc/ada/ChangeLog: * adadecode.c: Moved to... * adadecode.cc: ...here. * affinity.c: Moved to... * affinity.cc: ...here. * argv-lynxos178-raven-cert.c: Moved to... * argv-lynxos178-raven-cert.cc: ...here. * argv.c: Moved to... * argv.cc: ...here. * aux-io.c: Moved to... * aux-io.cc: ...here. * cio.c: Moved to... * cio.cc: ...here. * cstreams.c: Moved to... * cstreams.cc: ...here. * env.c: Moved to... * env.cc: ...here. * exit.c: Moved to... * exit.cc: ...here. * expect.c: Moved to... * expect.cc: ...here. * final.c: Moved to... * final.cc: ...here. * gcc-interface/cuintp.c: Moved to... * gcc-interface/cuintp.cc: ...here. * gcc-interface/decl.c: Moved to... * gcc-interface/decl.cc: ...here. * gcc-interface/misc.c: Moved to... * gcc-interface/misc.cc: ...here. * gcc-interface/targtyps.c: Moved to... * gcc-interface/targtyps.cc: ...here. * gcc-interface/trans.c: Moved to... * gcc-interface/trans.cc: ...here. * gcc-interface/utils.c: Moved to... * gcc-interface/utils.cc: ...here. * gcc-interface/utils2.c: Moved to... * gcc-interface/utils2.cc: ...here. * init.c: Moved to... * init.cc: ...here. * initialize.c: Moved to... * initialize.cc: ...here. * libgnarl/thread.c: Moved to... * libgnarl/thread.cc: ...here. * link.c: Moved to... * link.cc: ...here. * locales.c: Moved to... * locales.cc: ...here. * mkdir.c: Moved to... * mkdir.cc: ...here. * raise.c: Moved to... * raise.cc: ...here. * rtfinal.c: Moved to... * rtfinal.cc: ...here. * rtinit.c: Moved to... * rtinit.cc: ...here. * seh_init.c: Moved to... * seh_init.cc: ...here. * sigtramp-armdroid.c: Moved to... * sigtramp-armdroid.cc: ...here. * sigtramp-ios.c: Moved to... * sigtramp-ios.cc: ...here. * sigtramp-qnx.c: Moved to... * sigtramp-qnx.cc: ...here. * sigtramp-vxworks.c: Moved to... * sigtramp-vxworks.cc: ...here. * socket.c: Moved to... * socket.cc: ...here. * tracebak.c: Moved to... * tracebak.cc: ...here. * version.c: Moved to... * version.cc: ...here. * vx_stack_info.c: Moved to... * vx_stack_info.cc: ...here. gcc/ChangeLog: * adjust-alignment.c: Moved to... * adjust-alignment.cc: ...here. * alias.c: Moved to... * alias.cc: ...here. * alloc-pool.c: Moved to... * alloc-pool.cc: ...here. * asan.c: Moved to... * asan.cc: ...here. * attribs.c: Moved to... * attribs.cc: ...here. * auto-inc-dec.c: Moved to... * auto-inc-dec.cc: ...here. * auto-profile.c: Moved to... * auto-profile.cc: ...here. * bb-reorder.c: Moved to... * bb-reorder.cc: ...here. * bitmap.c: Moved to... * bitmap.cc: ...here. * btfout.c: Moved to... * btfout.cc: ...here. * builtins.c: Moved to... * builtins.cc: ...here. * caller-save.c: Moved to... * caller-save.cc: ...here. * calls.c: Moved to... * calls.cc: ...here. * ccmp.c: Moved to... * ccmp.cc: ...here. * cfg.c: Moved to... * cfg.cc: ...here. * cfganal.c: Moved to... * cfganal.cc: ...here. * cfgbuild.c: Moved to... * cfgbuild.cc: ...here. * cfgcleanup.c: Moved to... * cfgcleanup.cc: ...here. * cfgexpand.c: Moved to... * cfgexpand.cc: ...here. * cfghooks.c: Moved to... * cfghooks.cc: ...here. * cfgloop.c: Moved to... * cfgloop.cc: ...here. * cfgloopanal.c: Moved to... * cfgloopanal.cc: ...here. * cfgloopmanip.c: Moved to... * cfgloopmanip.cc: ...here. * cfgrtl.c: Moved to... * cfgrtl.cc: ...here. * cgraph.c: Moved to... * cgraph.cc: ...here. * cgraphbuild.c: Moved to... * cgraphbuild.cc: ...here. * cgraphclones.c: Moved to... * cgraphclones.cc: ...here. * cgraphunit.c: Moved to... * cgraphunit.cc: ...here. * collect-utils.c: Moved to... * collect-utils.cc: ...here. * collect2-aix.c: Moved to... * collect2-aix.cc: ...here. * collect2.c: Moved to... * collect2.cc: ...here. * combine-stack-adj.c: Moved to... * combine-stack-adj.cc: ...here. * combine.c: Moved to... * combine.cc: ...here. * common/common-targhooks.c: Moved to... * common/common-targhooks.cc: ...here. * common/config/aarch64/aarch64-common.c: Moved to... * common/config/aarch64/aarch64-common.cc: ...here. * common/config/alpha/alpha-common.c: Moved to... * common/config/alpha/alpha-common.cc: ...here. * common/config/arc/arc-common.c: Moved to... * common/config/arc/arc-common.cc: ...here. * common/config/arm/arm-common.c: Moved to... * common/config/arm/arm-common.cc: ...here. * common/config/avr/avr-common.c: Moved to... * common/config/avr/avr-common.cc: ...here. * common/config/bfin/bfin-common.c: Moved to... * common/config/bfin/bfin-common.cc: ...here. * common/config/bpf/bpf-common.c: Moved to... * common/config/bpf/bpf-common.cc: ...here. * common/config/c6x/c6x-common.c: Moved to... * common/config/c6x/c6x-common.cc: ...here. * common/config/cr16/cr16-common.c: Moved to... * common/config/cr16/cr16-common.cc: ...here. * common/config/cris/cris-common.c: Moved to... * common/config/cris/cris-common.cc: ...here. * common/config/csky/csky-common.c: Moved to... * common/config/csky/csky-common.cc: ...here. * common/config/default-common.c: Moved to... * common/config/default-common.cc: ...here. * common/config/epiphany/epiphany-common.c: Moved to... * common/config/epiphany/epiphany-common.cc: ...here. * common/config/fr30/fr30-common.c: Moved to... * common/config/fr30/fr30-common.cc: ...here. * common/config/frv/frv-common.c: Moved to... * common/config/frv/frv-common.cc: ...here. * common/config/gcn/gcn-common.c: Moved to... * common/config/gcn/gcn-common.cc: ...here. * common/config/h8300/h8300-common.c: Moved to... * common/config/h8300/h8300-common.cc: ...here. * common/config/i386/i386-common.c: Moved to... * common/config/i386/i386-common.cc: ...here. * common/config/ia64/ia64-common.c: Moved to... * common/config/ia64/ia64-common.cc: ...here. * common/config/iq2000/iq2000-common.c: Moved to... * common/config/iq2000/iq2000-common.cc: ...here. * common/config/lm32/lm32-common.c: Moved to... * common/config/lm32/lm32-common.cc: ...here. * common/config/m32r/m32r-common.c: Moved to... * common/config/m32r/m32r-common.cc: ...here. * common/config/m68k/m68k-common.c: Moved to... * common/config/m68k/m68k-common.cc: ...here. * common/config/mcore/mcore-common.c: Moved to... * common/config/mcore/mcore-common.cc: ...here. * common/config/microblaze/microblaze-common.c: Moved to... * common/config/microblaze/microblaze-common.cc: ...here. * common/config/mips/mips-common.c: Moved to... * common/config/mips/mips-common.cc: ...here. * common/config/mmix/mmix-common.c: Moved to... * common/config/mmix/mmix-common.cc: ...here. * common/config/mn10300/mn10300-common.c: Moved to... * common/config/mn10300/mn10300-common.cc: ...here. * common/config/msp430/msp430-common.c: Moved to... * common/config/msp430/msp430-common.cc: ...here. * common/config/nds32/nds32-common.c: Moved to... * common/config/nds32/nds32-common.cc: ...here. * common/config/nios2/nios2-common.c: Moved to... * common/config/nios2/nios2-common.cc: ...here. * common/config/nvptx/nvptx-common.c: Moved to... * common/config/nvptx/nvptx-common.cc: ...here. * common/config/or1k/or1k-common.c: Moved to... * common/config/or1k/or1k-common.cc: ...here. * common/config/pa/pa-common.c: Moved to... * common/config/pa/pa-common.cc: ...here. * common/config/pdp11/pdp11-common.c: Moved to... * common/config/pdp11/pdp11-common.cc: ...here. * common/config/pru/pru-common.c: Moved to... * common/config/pru/pru-common.cc: ...here. * common/config/riscv/riscv-common.c: Moved to... * common/config/riscv/riscv-common.cc: ...here. * common/config/rs6000/rs6000-common.c: Moved to... * common/config/rs6000/rs6000-common.cc: ...here. * common/config/rx/rx-common.c: Moved to... * common/config/rx/rx-common.cc: ...here. * common/config/s390/s390-common.c: Moved to... * common/config/s390/s390-common.cc: ...here. * common/config/sh/sh-common.c: Moved to... * common/config/sh/sh-common.cc: ...here. * common/config/sparc/sparc-common.c: Moved to... * common/config/sparc/sparc-common.cc: ...here. * common/config/tilegx/tilegx-common.c: Moved to... * common/config/tilegx/tilegx-common.cc: ...here. * common/config/tilepro/tilepro-common.c: Moved to... * common/config/tilepro/tilepro-common.cc: ...here. * common/config/v850/v850-common.c: Moved to... * common/config/v850/v850-common.cc: ...here. * common/config/vax/vax-common.c: Moved to... * common/config/vax/vax-common.cc: ...here. * common/config/visium/visium-common.c: Moved to... * common/config/visium/visium-common.cc: ...here. * common/config/xstormy16/xstormy16-common.c: Moved to... * common/config/xstormy16/xstormy16-common.cc: ...here. * common/config/xtensa/xtensa-common.c: Moved to... * common/config/xtensa/xtensa-common.cc: ...here. * compare-elim.c: Moved to... * compare-elim.cc: ...here. * config/aarch64/aarch64-bti-insert.c: Moved to... * config/aarch64/aarch64-bti-insert.cc: ...here. * config/aarch64/aarch64-builtins.c: Moved to... * config/aarch64/aarch64-builtins.cc: ...here. * config/aarch64/aarch64-c.c: Moved to... * config/aarch64/aarch64-c.cc: ...here. * config/aarch64/aarch64-d.c: Moved to... * config/aarch64/aarch64-d.cc: ...here. * config/aarch64/aarch64.c: Moved to... * config/aarch64/aarch64.cc: ...here. * config/aarch64/cortex-a57-fma-steering.c: Moved to... * config/aarch64/cortex-a57-fma-steering.cc: ...here. * config/aarch64/driver-aarch64.c: Moved to... * config/aarch64/driver-aarch64.cc: ...here. * config/aarch64/falkor-tag-collision-avoidance.c: Moved to... * config/aarch64/falkor-tag-collision-avoidance.cc: ...here. * config/aarch64/host-aarch64-darwin.c: Moved to... * config/aarch64/host-aarch64-darwin.cc: ...here. * config/alpha/alpha.c: Moved to... * config/alpha/alpha.cc: ...here. * config/alpha/driver-alpha.c: Moved to... * config/alpha/driver-alpha.cc: ...here. * config/arc/arc-c.c: Moved to... * config/arc/arc-c.cc: ...here. * config/arc/arc.c: Moved to... * config/arc/arc.cc: ...here. * config/arc/driver-arc.c: Moved to... * config/arc/driver-arc.cc: ...here. * config/arm/aarch-common.c: Moved to... * config/arm/aarch-common.cc: ...here. * config/arm/arm-builtins.c: Moved to... * config/arm/arm-builtins.cc: ...here. * config/arm/arm-c.c: Moved to... * config/arm/arm-c.cc: ...here. * config/arm/arm-d.c: Moved to... * config/arm/arm-d.cc: ...here. * config/arm/arm.c: Moved to... * config/arm/arm.cc: ...here. * config/arm/driver-arm.c: Moved to... * config/arm/driver-arm.cc: ...here. * config/avr/avr-c.c: Moved to... * config/avr/avr-c.cc: ...here. * config/avr/avr-devices.c: Moved to... * config/avr/avr-devices.cc: ...here. * config/avr/avr-log.c: Moved to... * config/avr/avr-log.cc: ...here. * config/avr/avr.c: Moved to... * config/avr/avr.cc: ...here. * config/avr/driver-avr.c: Moved to... * config/avr/driver-avr.cc: ...here. * config/avr/gen-avr-mmcu-specs.c: Moved to... * config/avr/gen-avr-mmcu-specs.cc: ...here. * config/avr/gen-avr-mmcu-texi.c: Moved to... * config/avr/gen-avr-mmcu-texi.cc: ...here. * config/bfin/bfin.c: Moved to... * config/bfin/bfin.cc: ...here. * config/bpf/bpf.c: Moved to... * config/bpf/bpf.cc: ...here. * config/bpf/coreout.c: Moved to... * config/bpf/coreout.cc: ...here. * config/c6x/c6x.c: Moved to... * config/c6x/c6x.cc: ...here. * config/cr16/cr16.c: Moved to... * config/cr16/cr16.cc: ...here. * config/cris/cris.c: Moved to... * config/cris/cris.cc: ...here. * config/csky/csky.c: Moved to... * config/csky/csky.cc: ...here. * config/darwin-c.c: Moved to... * config/darwin-c.cc: ...here. * config/darwin-d.c: Moved to... * config/darwin-d.cc: ...here. * config/darwin-driver.c: Moved to... * config/darwin-driver.cc: ...here. * config/darwin-f.c: Moved to... * config/darwin-f.cc: ...here. * config/darwin.c: Moved to... * config/darwin.cc: ...here. * config/default-c.c: Moved to... * config/default-c.cc: ...here. * config/default-d.c: Moved to... * config/default-d.cc: ...here. * config/dragonfly-d.c: Moved to... * config/dragonfly-d.cc: ...here. * config/epiphany/epiphany.c: Moved to... * config/epiphany/epiphany.cc: ...here. * config/epiphany/mode-switch-use.c: Moved to... * config/epiphany/mode-switch-use.cc: ...here. * config/epiphany/resolve-sw-modes.c: Moved to... * config/epiphany/resolve-sw-modes.cc: ...here. * config/fr30/fr30.c: Moved to... * config/fr30/fr30.cc: ...here. * config/freebsd-d.c: Moved to... * config/freebsd-d.cc: ...here. * config/frv/frv.c: Moved to... * config/frv/frv.cc: ...here. * config/ft32/ft32.c: Moved to... * config/ft32/ft32.cc: ...here. * config/gcn/driver-gcn.c: Moved to... * config/gcn/driver-gcn.cc: ...here. * config/gcn/gcn-run.c: Moved to... * config/gcn/gcn-run.cc: ...here. * config/gcn/gcn-tree.c: Moved to... * config/gcn/gcn-tree.cc: ...here. * config/gcn/gcn.c: Moved to... * config/gcn/gcn.cc: ...here. * config/gcn/mkoffload.c: Moved to... * config/gcn/mkoffload.cc: ...here. * config/glibc-c.c: Moved to... * config/glibc-c.cc: ...here. * config/glibc-d.c: Moved to... * config/glibc-d.cc: ...here. * config/h8300/h8300.c: Moved to... * config/h8300/h8300.cc: ...here. * config/host-darwin.c: Moved to... * config/host-darwin.cc: ...here. * config/host-hpux.c: Moved to... * config/host-hpux.cc: ...here. * config/host-linux.c: Moved to... * config/host-linux.cc: ...here. * config/host-netbsd.c: Moved to... * config/host-netbsd.cc: ...here. * config/host-openbsd.c: Moved to... * config/host-openbsd.cc: ...here. * config/host-solaris.c: Moved to... * config/host-solaris.cc: ...here. * config/i386/djgpp.c: Moved to... * config/i386/djgpp.cc: ...here. * config/i386/driver-i386.c: Moved to... * config/i386/driver-i386.cc: ...here. * config/i386/driver-mingw32.c: Moved to... * config/i386/driver-mingw32.cc: ...here. * config/i386/gnu-property.c: Moved to... * config/i386/gnu-property.cc: ...here. * config/i386/host-cygwin.c: Moved to... * config/i386/host-cygwin.cc: ...here. * config/i386/host-i386-darwin.c: Moved to... * config/i386/host-i386-darwin.cc: ...here. * config/i386/host-mingw32.c: Moved to... * config/i386/host-mingw32.cc: ...here. * config/i386/i386-builtins.c: Moved to... * config/i386/i386-builtins.cc: ...here. * config/i386/i386-c.c: Moved to... * config/i386/i386-c.cc: ...here. * config/i386/i386-d.c: Moved to... * config/i386/i386-d.cc: ...here. * config/i386/i386-expand.c: Moved to... * config/i386/i386-expand.cc: ...here. * config/i386/i386-features.c: Moved to... * config/i386/i386-features.cc: ...here. * config/i386/i386-options.c: Moved to... * config/i386/i386-options.cc: ...here. * config/i386/i386.c: Moved to... * config/i386/i386.cc: ...here. * config/i386/intelmic-mkoffload.c: Moved to... * config/i386/intelmic-mkoffload.cc: ...here. * config/i386/msformat-c.c: Moved to... * config/i386/msformat-c.cc: ...here. * config/i386/winnt-cxx.c: Moved to... * config/i386/winnt-cxx.cc: ...here. * config/i386/winnt-d.c: Moved to... * config/i386/winnt-d.cc: ...here. * config/i386/winnt-stubs.c: Moved to... * config/i386/winnt-stubs.cc: ...here. * config/i386/winnt.c: Moved to... * config/i386/winnt.cc: ...here. * config/i386/x86-tune-sched-atom.c: Moved to... * config/i386/x86-tune-sched-atom.cc: ...here. * config/i386/x86-tune-sched-bd.c: Moved to... * config/i386/x86-tune-sched-bd.cc: ...here. * config/i386/x86-tune-sched-core.c: Moved to... * config/i386/x86-tune-sched-core.cc: ...here. * config/i386/x86-tune-sched.c: Moved to... * config/i386/x86-tune-sched.cc: ...here. * config/ia64/ia64-c.c: Moved to... * config/ia64/ia64-c.cc: ...here. * config/ia64/ia64.c: Moved to... * config/ia64/ia64.cc: ...here. * config/iq2000/iq2000.c: Moved to... * config/iq2000/iq2000.cc: ...here. * config/linux.c: Moved to... * config/linux.cc: ...here. * config/lm32/lm32.c: Moved to... * config/lm32/lm32.cc: ...here. * config/m32c/m32c-pragma.c: Moved to... * config/m32c/m32c-pragma.cc: ...here. * config/m32c/m32c.c: Moved to... * config/m32c/m32c.cc: ...here. * config/m32r/m32r.c: Moved to... * config/m32r/m32r.cc: ...here. * config/m68k/m68k.c: Moved to... * config/m68k/m68k.cc: ...here. * config/mcore/mcore.c: Moved to... * config/mcore/mcore.cc: ...here. * config/microblaze/microblaze-c.c: Moved to... * config/microblaze/microblaze-c.cc: ...here. * config/microblaze/microblaze.c: Moved to... * config/microblaze/microblaze.cc: ...here. * config/mips/driver-native.c: Moved to... * config/mips/driver-native.cc: ...here. * config/mips/frame-header-opt.c: Moved to... * config/mips/frame-header-opt.cc: ...here. * config/mips/mips-d.c: Moved to... * config/mips/mips-d.cc: ...here. * config/mips/mips.c: Moved to... * config/mips/mips.cc: ...here. * config/mmix/mmix.c: Moved to... * config/mmix/mmix.cc: ...here. * config/mn10300/mn10300.c: Moved to... * config/mn10300/mn10300.cc: ...here. * config/moxie/moxie.c: Moved to... * config/moxie/moxie.cc: ...here. * config/msp430/driver-msp430.c: Moved to... * config/msp430/driver-msp430.cc: ...here. * config/msp430/msp430-c.c: Moved to... * config/msp430/msp430-c.cc: ...here. * config/msp430/msp430-devices.c: Moved to... * config/msp430/msp430-devices.cc: ...here. * config/msp430/msp430.c: Moved to... * config/msp430/msp430.cc: ...here. * config/nds32/nds32-cost.c: Moved to... * config/nds32/nds32-cost.cc: ...here. * config/nds32/nds32-fp-as-gp.c: Moved to... * config/nds32/nds32-fp-as-gp.cc: ...here. * config/nds32/nds32-intrinsic.c: Moved to... * config/nds32/nds32-intrinsic.cc: ...here. * config/nds32/nds32-isr.c: Moved to... * config/nds32/nds32-isr.cc: ...here. * config/nds32/nds32-md-auxiliary.c: Moved to... * config/nds32/nds32-md-auxiliary.cc: ...here. * config/nds32/nds32-memory-manipulation.c: Moved to... * config/nds32/nds32-memory-manipulation.cc: ...here. * config/nds32/nds32-pipelines-auxiliary.c: Moved to... * config/nds32/nds32-pipelines-auxiliary.cc: ...here. * config/nds32/nds32-predicates.c: Moved to... * config/nds32/nds32-predicates.cc: ...here. * config/nds32/nds32-relax-opt.c: Moved to... * config/nds32/nds32-relax-opt.cc: ...here. * config/nds32/nds32-utils.c: Moved to... * config/nds32/nds32-utils.cc: ...here. * config/nds32/nds32.c: Moved to... * config/nds32/nds32.cc: ...here. * config/netbsd-d.c: Moved to... * config/netbsd-d.cc: ...here. * config/netbsd.c: Moved to... * config/netbsd.cc: ...here. * config/nios2/nios2.c: Moved to... * config/nios2/nios2.cc: ...here. * config/nvptx/mkoffload.c: Moved to... * config/nvptx/mkoffload.cc: ...here. * config/nvptx/nvptx-c.c: Moved to... * config/nvptx/nvptx-c.cc: ...here. * config/nvptx/nvptx.c: Moved to... * config/nvptx/nvptx.cc: ...here. * config/openbsd-d.c: Moved to... * config/openbsd-d.cc: ...here. * config/or1k/or1k.c: Moved to... * config/or1k/or1k.cc: ...here. * config/pa/pa-d.c: Moved to... * config/pa/pa-d.cc: ...here. * config/pa/pa.c: Moved to... * config/pa/pa.cc: ...here. * config/pdp11/pdp11.c: Moved to... * config/pdp11/pdp11.cc: ...here. * config/pru/pru-passes.c: Moved to... * config/pru/pru-passes.cc: ...here. * config/pru/pru-pragma.c: Moved to... * config/pru/pru-pragma.cc: ...here. * config/pru/pru.c: Moved to... * config/pru/pru.cc: ...here. * config/riscv/riscv-builtins.c: Moved to... * config/riscv/riscv-builtins.cc: ...here. * config/riscv/riscv-c.c: Moved to... * config/riscv/riscv-c.cc: ...here. * config/riscv/riscv-d.c: Moved to... * config/riscv/riscv-d.cc: ...here. * config/riscv/riscv-shorten-memrefs.c: Moved to... * config/riscv/riscv-shorten-memrefs.cc: ...here. * config/riscv/riscv-sr.c: Moved to... * config/riscv/riscv-sr.cc: ...here. * config/riscv/riscv.c: Moved to... * config/riscv/riscv.cc: ...here. * config/rl78/rl78-c.c: Moved to... * config/rl78/rl78-c.cc: ...here. * config/rl78/rl78.c: Moved to... * config/rl78/rl78.cc: ...here. * config/rs6000/driver-rs6000.c: Moved to... * config/rs6000/driver-rs6000.cc: ...here. * config/rs6000/host-darwin.c: Moved to... * config/rs6000/host-darwin.cc: ...here. * config/rs6000/host-ppc64-darwin.c: Moved to... * config/rs6000/host-ppc64-darwin.cc: ...here. * config/rs6000/rbtree.c: Moved to... * config/rs6000/rbtree.cc: ...here. * config/rs6000/rs6000-c.c: Moved to... * config/rs6000/rs6000-c.cc: ...here. * config/rs6000/rs6000-call.c: Moved to... * config/rs6000/rs6000-call.cc: ...here. * config/rs6000/rs6000-d.c: Moved to... * config/rs6000/rs6000-d.cc: ...here. * config/rs6000/rs6000-gen-builtins.c: Moved to... * config/rs6000/rs6000-gen-builtins.cc: ...here. * config/rs6000/rs6000-linux.c: Moved to... * config/rs6000/rs6000-linux.cc: ...here. * config/rs6000/rs6000-logue.c: Moved to... * config/rs6000/rs6000-logue.cc: ...here. * config/rs6000/rs6000-p8swap.c: Moved to... * config/rs6000/rs6000-p8swap.cc: ...here. * config/rs6000/rs6000-pcrel-opt.c: Moved to... * config/rs6000/rs6000-pcrel-opt.cc: ...here. * config/rs6000/rs6000-string.c: Moved to... * config/rs6000/rs6000-string.cc: ...here. * config/rs6000/rs6000.c: Moved to... * config/rs6000/rs6000.cc: ...here. * config/rx/rx.c: Moved to... * config/rx/rx.cc: ...here. * config/s390/driver-native.c: Moved to... * config/s390/driver-native.cc: ...here. * config/s390/s390-c.c: Moved to... * config/s390/s390-c.cc: ...here. * config/s390/s390-d.c: Moved to... * config/s390/s390-d.cc: ...here. * config/s390/s390.c: Moved to... * config/s390/s390.cc: ...here. * config/sh/divtab-sh4-300.c: Moved to... * config/sh/divtab-sh4-300.cc: ...here. * config/sh/divtab-sh4.c: Moved to... * config/sh/divtab-sh4.cc: ...here. * config/sh/divtab.c: Moved to... * config/sh/divtab.cc: ...here. * config/sh/sh-c.c: Moved to... * config/sh/sh-c.cc: ...here. * config/sh/sh.c: Moved to... * config/sh/sh.cc: ...here. * config/sol2-c.c: Moved to... * config/sol2-c.cc: ...here. * config/sol2-cxx.c: Moved to... * config/sol2-cxx.cc: ...here. * config/sol2-d.c: Moved to... * config/sol2-d.cc: ...here. * config/sol2-stubs.c: Moved to... * config/sol2-stubs.cc: ...here. * config/sol2.c: Moved to... * config/sol2.cc: ...here. * config/sparc/driver-sparc.c: Moved to... * config/sparc/driver-sparc.cc: ...here. * config/sparc/sparc-c.c: Moved to... * config/sparc/sparc-c.cc: ...here. * config/sparc/sparc-d.c: Moved to... * config/sparc/sparc-d.cc: ...here. * config/sparc/sparc.c: Moved to... * config/sparc/sparc.cc: ...here. * config/stormy16/stormy16.c: Moved to... * config/stormy16/stormy16.cc: ...here. * config/tilegx/mul-tables.c: Moved to... * config/tilegx/mul-tables.cc: ...here. * config/tilegx/tilegx-c.c: Moved to... * config/tilegx/tilegx-c.cc: ...here. * config/tilegx/tilegx.c: Moved to... * config/tilegx/tilegx.cc: ...here. * config/tilepro/mul-tables.c: Moved to... * config/tilepro/mul-tables.cc: ...here. * config/tilepro/tilepro-c.c: Moved to... * config/tilepro/tilepro-c.cc: ...here. * config/tilepro/tilepro.c: Moved to... * config/tilepro/tilepro.cc: ...here. * config/v850/v850-c.c: Moved to... * config/v850/v850-c.cc: ...here. * config/v850/v850.c: Moved to... * config/v850/v850.cc: ...here. * config/vax/vax.c: Moved to... * config/vax/vax.cc: ...here. * config/visium/visium.c: Moved to... * config/visium/visium.cc: ...here. * config/vms/vms-c.c: Moved to... * config/vms/vms-c.cc: ...here. * config/vms/vms-f.c: Moved to... * config/vms/vms-f.cc: ...here. * config/vms/vms.c: Moved to... * config/vms/vms.cc: ...here. * config/vxworks-c.c: Moved to... * config/vxworks-c.cc: ...here. * config/vxworks.c: Moved to... * config/vxworks.cc: ...here. * config/winnt-c.c: Moved to... * config/winnt-c.cc: ...here. * config/xtensa/xtensa.c: Moved to... * config/xtensa/xtensa.cc: ...here. * context.c: Moved to... * context.cc: ...here. * convert.c: Moved to... * convert.cc: ...here. * coverage.c: Moved to... * coverage.cc: ...here. * cppbuiltin.c: Moved to... * cppbuiltin.cc: ...here. * cppdefault.c: Moved to... * cppdefault.cc: ...here. * cprop.c: Moved to... * cprop.cc: ...here. * cse.c: Moved to... * cse.cc: ...here. * cselib.c: Moved to... * cselib.cc: ...here. * ctfc.c: Moved to... * ctfc.cc: ...here. * ctfout.c: Moved to... * ctfout.cc: ...here. * data-streamer-in.c: Moved to... * data-streamer-in.cc: ...here. * data-streamer-out.c: Moved to... * data-streamer-out.cc: ...here. * data-streamer.c: Moved to... * data-streamer.cc: ...here. * dbgcnt.c: Moved to... * dbgcnt.cc: ...here. * dbxout.c: Moved to... * dbxout.cc: ...here. * dce.c: Moved to... * dce.cc: ...here. * ddg.c: Moved to... * ddg.cc: ...here. * debug.c: Moved to... * debug.cc: ...here. * df-core.c: Moved to... * df-core.cc: ...here. * df-problems.c: Moved to... * df-problems.cc: ...here. * df-scan.c: Moved to... * df-scan.cc: ...here. * dfp.c: Moved to... * dfp.cc: ...here. * diagnostic-color.c: Moved to... * diagnostic-color.cc: ...here. * diagnostic-show-locus.c: Moved to... * diagnostic-show-locus.cc: ...here. * diagnostic-spec.c: Moved to... * diagnostic-spec.cc: ...here. * diagnostic.c: Moved to... * diagnostic.cc: ...here. * dojump.c: Moved to... * dojump.cc: ...here. * dominance.c: Moved to... * dominance.cc: ...here. * domwalk.c: Moved to... * domwalk.cc: ...here. * double-int.c: Moved to... * double-int.cc: ...here. * dse.c: Moved to... * dse.cc: ...here. * dumpfile.c: Moved to... * dumpfile.cc: ...here. * dwarf2asm.c: Moved to... * dwarf2asm.cc: ...here. * dwarf2cfi.c: Moved to... * dwarf2cfi.cc: ...here. * dwarf2ctf.c: Moved to... * dwarf2ctf.cc: ...here. * dwarf2out.c: Moved to... * dwarf2out.cc: ...here. * early-remat.c: Moved to... * early-remat.cc: ...here. * edit-context.c: Moved to... * edit-context.cc: ...here. * emit-rtl.c: Moved to... * emit-rtl.cc: ...here. * errors.c: Moved to... * errors.cc: ...here. * et-forest.c: Moved to... * et-forest.cc: ...here. * except.c: Moved to... * except.cc: ...here. * explow.c: Moved to... * explow.cc: ...here. * expmed.c: Moved to... * expmed.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * fibonacci_heap.c: Moved to... * fibonacci_heap.cc: ...here. * file-find.c: Moved to... * file-find.cc: ...here. * file-prefix-map.c: Moved to... * file-prefix-map.cc: ...here. * final.c: Moved to... * final.cc: ...here. * fixed-value.c: Moved to... * fixed-value.cc: ...here. * fold-const-call.c: Moved to... * fold-const-call.cc: ...here. * fold-const.c: Moved to... * fold-const.cc: ...here. * fp-test.c: Moved to... * fp-test.cc: ...here. * function-tests.c: Moved to... * function-tests.cc: ...here. * function.c: Moved to... * function.cc: ...here. * fwprop.c: Moved to... * fwprop.cc: ...here. * gcc-ar.c: Moved to... * gcc-ar.cc: ...here. * gcc-main.c: Moved to... * gcc-main.cc: ...here. * gcc-rich-location.c: Moved to... * gcc-rich-location.cc: ...here. * gcc.c: Moved to... * gcc.cc: ...here. * gcov-dump.c: Moved to... * gcov-dump.cc: ...here. * gcov-io.c: Moved to... * gcov-io.cc: ...here. * gcov-tool.c: Moved to... * gcov-tool.cc: ...here. * gcov.c: Moved to... * gcov.cc: ...here. * gcse-common.c: Moved to... * gcse-common.cc: ...here. * gcse.c: Moved to... * gcse.cc: ...here. * genattr-common.c: Moved to... * genattr-common.cc: ...here. * genattr.c: Moved to... * genattr.cc: ...here. * genattrtab.c: Moved to... * genattrtab.cc: ...here. * genautomata.c: Moved to... * genautomata.cc: ...here. * gencfn-macros.c: Moved to... * gencfn-macros.cc: ...here. * gencheck.c: Moved to... * gencheck.cc: ...here. * genchecksum.c: Moved to... * genchecksum.cc: ...here. * gencodes.c: Moved to... * gencodes.cc: ...here. * genconditions.c: Moved to... * genconditions.cc: ...here. * genconfig.c: Moved to... * genconfig.cc: ...here. * genconstants.c: Moved to... * genconstants.cc: ...here. * genemit.c: Moved to... * genemit.cc: ...here. * genenums.c: Moved to... * genenums.cc: ...here. * generic-match-head.c: Moved to... * generic-match-head.cc: ...here. * genextract.c: Moved to... * genextract.cc: ...here. * genflags.c: Moved to... * genflags.cc: ...here. * gengenrtl.c: Moved to... * gengenrtl.cc: ...here. * gengtype-parse.c: Moved to... * gengtype-parse.cc: ...here. * gengtype-state.c: Moved to... * gengtype-state.cc: ...here. * gengtype.c: Moved to... * gengtype.cc: ...here. * genhooks.c: Moved to... * genhooks.cc: ...here. * genmatch.c: Moved to... * genmatch.cc: ...here. * genmddeps.c: Moved to... * genmddeps.cc: ...here. * genmddump.c: Moved to... * genmddump.cc: ...here. * genmodes.c: Moved to... * genmodes.cc: ...here. * genopinit.c: Moved to... * genopinit.cc: ...here. * genoutput.c: Moved to... * genoutput.cc: ...here. * genpeep.c: Moved to... * genpeep.cc: ...here. * genpreds.c: Moved to... * genpreds.cc: ...here. * genrecog.c: Moved to... * genrecog.cc: ...here. * gensupport.c: Moved to... * gensupport.cc: ...here. * gentarget-def.c: Moved to... * gentarget-def.cc: ...here. * genversion.c: Moved to... * genversion.cc: ...here. * ggc-common.c: Moved to... * ggc-common.cc: ...here. * ggc-none.c: Moved to... * ggc-none.cc: ...here. * ggc-page.c: Moved to... * ggc-page.cc: ...here. * ggc-tests.c: Moved to... * ggc-tests.cc: ...here. * gimple-builder.c: Moved to... * gimple-builder.cc: ...here. * gimple-expr.c: Moved to... * gimple-expr.cc: ...here. * gimple-fold.c: Moved to... * gimple-fold.cc: ...here. * gimple-iterator.c: Moved to... * gimple-iterator.cc: ...here. * gimple-laddress.c: Moved to... * gimple-laddress.cc: ...here. * gimple-loop-jam.c: Moved to... * gimple-loop-jam.cc: ...here. * gimple-low.c: Moved to... * gimple-low.cc: ...here. * gimple-match-head.c: Moved to... * gimple-match-head.cc: ...here. * gimple-pretty-print.c: Moved to... * gimple-pretty-print.cc: ...here. * gimple-ssa-backprop.c: Moved to... * gimple-ssa-backprop.cc: ...here. * gimple-ssa-evrp-analyze.c: Moved to... * gimple-ssa-evrp-analyze.cc: ...here. * gimple-ssa-evrp.c: Moved to... * gimple-ssa-evrp.cc: ...here. * gimple-ssa-isolate-paths.c: Moved to... * gimple-ssa-isolate-paths.cc: ...here. * gimple-ssa-nonnull-compare.c: Moved to... * gimple-ssa-nonnull-compare.cc: ...here. * gimple-ssa-split-paths.c: Moved to... * gimple-ssa-split-paths.cc: ...here. * gimple-ssa-sprintf.c: Moved to... * gimple-ssa-sprintf.cc: ...here. * gimple-ssa-store-merging.c: Moved to... * gimple-ssa-store-merging.cc: ...here. * gimple-ssa-strength-reduction.c: Moved to... * gimple-ssa-strength-reduction.cc: ...here. * gimple-ssa-warn-alloca.c: Moved to... * gimple-ssa-warn-alloca.cc: ...here. * gimple-ssa-warn-restrict.c: Moved to... * gimple-ssa-warn-restrict.cc: ...here. * gimple-streamer-in.c: Moved to... * gimple-streamer-in.cc: ...here. * gimple-streamer-out.c: Moved to... * gimple-streamer-out.cc: ...here. * gimple-walk.c: Moved to... * gimple-walk.cc: ...here. * gimple-warn-recursion.c: Moved to... * gimple-warn-recursion.cc: ...here. * gimple.c: Moved to... * gimple.cc: ...here. * gimplify-me.c: Moved to... * gimplify-me.cc: ...here. * gimplify.c: Moved to... * gimplify.cc: ...here. * godump.c: Moved to... * godump.cc: ...here. * graph.c: Moved to... * graph.cc: ...here. * graphds.c: Moved to... * graphds.cc: ...here. * graphite-dependences.c: Moved to... * graphite-dependences.cc: ...here. * graphite-isl-ast-to-gimple.c: Moved to... * graphite-isl-ast-to-gimple.cc: ...here. * graphite-optimize-isl.c: Moved to... * graphite-optimize-isl.cc: ...here. * graphite-poly.c: Moved to... * graphite-poly.cc: ...here. * graphite-scop-detection.c: Moved to... * graphite-scop-detection.cc: ...here. * graphite-sese-to-poly.c: Moved to... * graphite-sese-to-poly.cc: ...here. * graphite.c: Moved to... * graphite.cc: ...here. * haifa-sched.c: Moved to... * haifa-sched.cc: ...here. * hash-map-tests.c: Moved to... * hash-map-tests.cc: ...here. * hash-set-tests.c: Moved to... * hash-set-tests.cc: ...here. * hash-table.c: Moved to... * hash-table.cc: ...here. * hooks.c: Moved to... * hooks.cc: ...here. * host-default.c: Moved to... * host-default.cc: ...here. * hw-doloop.c: Moved to... * hw-doloop.cc: ...here. * hwint.c: Moved to... * hwint.cc: ...here. * ifcvt.c: Moved to... * ifcvt.cc: ...here. * inchash.c: Moved to... * inchash.cc: ...here. * incpath.c: Moved to... * incpath.cc: ...here. * init-regs.c: Moved to... * init-regs.cc: ...here. * input.c: Moved to... * input.cc: ...here. * internal-fn.c: Moved to... * internal-fn.cc: ...here. * intl.c: Moved to... * intl.cc: ...here. * ipa-comdats.c: Moved to... * ipa-comdats.cc: ...here. * ipa-cp.c: Moved to... * ipa-cp.cc: ...here. * ipa-devirt.c: Moved to... * ipa-devirt.cc: ...here. * ipa-fnsummary.c: Moved to... * ipa-fnsummary.cc: ...here. * ipa-icf-gimple.c: Moved to... * ipa-icf-gimple.cc: ...here. * ipa-icf.c: Moved to... * ipa-icf.cc: ...here. * ipa-inline-analysis.c: Moved to... * ipa-inline-analysis.cc: ...here. * ipa-inline-transform.c: Moved to... * ipa-inline-transform.cc: ...here. * ipa-inline.c: Moved to... * ipa-inline.cc: ...here. * ipa-modref-tree.c: Moved to... * ipa-modref-tree.cc: ...here. * ipa-modref.c: Moved to... * ipa-modref.cc: ...here. * ipa-param-manipulation.c: Moved to... * ipa-param-manipulation.cc: ...here. * ipa-polymorphic-call.c: Moved to... * ipa-polymorphic-call.cc: ...here. * ipa-predicate.c: Moved to... * ipa-predicate.cc: ...here. * ipa-profile.c: Moved to... * ipa-profile.cc: ...here. * ipa-prop.c: Moved to... * ipa-prop.cc: ...here. * ipa-pure-const.c: Moved to... * ipa-pure-const.cc: ...here. * ipa-ref.c: Moved to... * ipa-ref.cc: ...here. * ipa-reference.c: Moved to... * ipa-reference.cc: ...here. * ipa-split.c: Moved to... * ipa-split.cc: ...here. * ipa-sra.c: Moved to... * ipa-sra.cc: ...here. * ipa-utils.c: Moved to... * ipa-utils.cc: ...here. * ipa-visibility.c: Moved to... * ipa-visibility.cc: ...here. * ipa.c: Moved to... * ipa.cc: ...here. * ira-build.c: Moved to... * ira-build.cc: ...here. * ira-color.c: Moved to... * ira-color.cc: ...here. * ira-conflicts.c: Moved to... * ira-conflicts.cc: ...here. * ira-costs.c: Moved to... * ira-costs.cc: ...here. * ira-emit.c: Moved to... * ira-emit.cc: ...here. * ira-lives.c: Moved to... * ira-lives.cc: ...here. * ira.c: Moved to... * ira.cc: ...here. * jump.c: Moved to... * jump.cc: ...here. * langhooks.c: Moved to... * langhooks.cc: ...here. * lcm.c: Moved to... * lcm.cc: ...here. * lists.c: Moved to... * lists.cc: ...here. * loop-doloop.c: Moved to... * loop-doloop.cc: ...here. * loop-init.c: Moved to... * loop-init.cc: ...here. * loop-invariant.c: Moved to... * loop-invariant.cc: ...here. * loop-iv.c: Moved to... * loop-iv.cc: ...here. * loop-unroll.c: Moved to... * loop-unroll.cc: ...here. * lower-subreg.c: Moved to... * lower-subreg.cc: ...here. * lra-assigns.c: Moved to... * lra-assigns.cc: ...here. * lra-coalesce.c: Moved to... * lra-coalesce.cc: ...here. * lra-constraints.c: Moved to... * lra-constraints.cc: ...here. * lra-eliminations.c: Moved to... * lra-eliminations.cc: ...here. * lra-lives.c: Moved to... * lra-lives.cc: ...here. * lra-remat.c: Moved to... * lra-remat.cc: ...here. * lra-spills.c: Moved to... * lra-spills.cc: ...here. * lra.c: Moved to... * lra.cc: ...here. * lto-cgraph.c: Moved to... * lto-cgraph.cc: ...here. * lto-compress.c: Moved to... * lto-compress.cc: ...here. * lto-opts.c: Moved to... * lto-opts.cc: ...here. * lto-section-in.c: Moved to... * lto-section-in.cc: ...here. * lto-section-out.c: Moved to... * lto-section-out.cc: ...here. * lto-streamer-in.c: Moved to... * lto-streamer-in.cc: ...here. * lto-streamer-out.c: Moved to... * lto-streamer-out.cc: ...here. * lto-streamer.c: Moved to... * lto-streamer.cc: ...here. * lto-wrapper.c: Moved to... * lto-wrapper.cc: ...here. * main.c: Moved to... * main.cc: ...here. * mcf.c: Moved to... * mcf.cc: ...here. * mode-switching.c: Moved to... * mode-switching.cc: ...here. * modulo-sched.c: Moved to... * modulo-sched.cc: ...here. * multiple_target.c: Moved to... * multiple_target.cc: ...here. * omp-expand.c: Moved to... * omp-expand.cc: ...here. * omp-general.c: Moved to... * omp-general.cc: ...here. * omp-low.c: Moved to... * omp-low.cc: ...here. * omp-offload.c: Moved to... * omp-offload.cc: ...here. * omp-simd-clone.c: Moved to... * omp-simd-clone.cc: ...here. * opt-suggestions.c: Moved to... * opt-suggestions.cc: ...here. * optabs-libfuncs.c: Moved to... * optabs-libfuncs.cc: ...here. * optabs-query.c: Moved to... * optabs-query.cc: ...here. * optabs-tree.c: Moved to... * optabs-tree.cc: ...here. * optabs.c: Moved to... * optabs.cc: ...here. * opts-common.c: Moved to... * opts-common.cc: ...here. * opts-global.c: Moved to... * opts-global.cc: ...here. * opts.c: Moved to... * opts.cc: ...here. * passes.c: Moved to... * passes.cc: ...here. * plugin.c: Moved to... * plugin.cc: ...here. * postreload-gcse.c: Moved to... * postreload-gcse.cc: ...here. * postreload.c: Moved to... * postreload.cc: ...here. * predict.c: Moved to... * predict.cc: ...here. * prefix.c: Moved to... * prefix.cc: ...here. * pretty-print.c: Moved to... * pretty-print.cc: ...here. * print-rtl-function.c: Moved to... * print-rtl-function.cc: ...here. * print-rtl.c: Moved to... * print-rtl.cc: ...here. * print-tree.c: Moved to... * print-tree.cc: ...here. * profile-count.c: Moved to... * profile-count.cc: ...here. * profile.c: Moved to... * profile.cc: ...here. * read-md.c: Moved to... * read-md.cc: ...here. * read-rtl-function.c: Moved to... * read-rtl-function.cc: ...here. * read-rtl.c: Moved to... * read-rtl.cc: ...here. * real.c: Moved to... * real.cc: ...here. * realmpfr.c: Moved to... * realmpfr.cc: ...here. * recog.c: Moved to... * recog.cc: ...here. * ree.c: Moved to... * ree.cc: ...here. * reg-stack.c: Moved to... * reg-stack.cc: ...here. * regcprop.c: Moved to... * regcprop.cc: ...here. * reginfo.c: Moved to... * reginfo.cc: ...here. * regrename.c: Moved to... * regrename.cc: ...here. * regstat.c: Moved to... * regstat.cc: ...here. * reload.c: Moved to... * reload.cc: ...here. * reload1.c: Moved to... * reload1.cc: ...here. * reorg.c: Moved to... * reorg.cc: ...here. * resource.c: Moved to... * resource.cc: ...here. * rtl-error.c: Moved to... * rtl-error.cc: ...here. * rtl-tests.c: Moved to... * rtl-tests.cc: ...here. * rtl.c: Moved to... * rtl.cc: ...here. * rtlanal.c: Moved to... * rtlanal.cc: ...here. * rtlhash.c: Moved to... * rtlhash.cc: ...here. * rtlhooks.c: Moved to... * rtlhooks.cc: ...here. * rtx-vector-builder.c: Moved to... * rtx-vector-builder.cc: ...here. * run-rtl-passes.c: Moved to... * run-rtl-passes.cc: ...here. * sancov.c: Moved to... * sancov.cc: ...here. * sanopt.c: Moved to... * sanopt.cc: ...here. * sbitmap.c: Moved to... * sbitmap.cc: ...here. * sched-deps.c: Moved to... * sched-deps.cc: ...here. * sched-ebb.c: Moved to... * sched-ebb.cc: ...here. * sched-rgn.c: Moved to... * sched-rgn.cc: ...here. * sel-sched-dump.c: Moved to... * sel-sched-dump.cc: ...here. * sel-sched-ir.c: Moved to... * sel-sched-ir.cc: ...here. * sel-sched.c: Moved to... * sel-sched.cc: ...here. * selftest-diagnostic.c: Moved to... * selftest-diagnostic.cc: ...here. * selftest-rtl.c: Moved to... * selftest-rtl.cc: ...here. * selftest-run-tests.c: Moved to... * selftest-run-tests.cc: ...here. * selftest.c: Moved to... * selftest.cc: ...here. * sese.c: Moved to... * sese.cc: ...here. * shrink-wrap.c: Moved to... * shrink-wrap.cc: ...here. * simplify-rtx.c: Moved to... * simplify-rtx.cc: ...here. * sparseset.c: Moved to... * sparseset.cc: ...here. * spellcheck-tree.c: Moved to... * spellcheck-tree.cc: ...here. * spellcheck.c: Moved to... * spellcheck.cc: ...here. * sreal.c: Moved to... * sreal.cc: ...here. * stack-ptr-mod.c: Moved to... * stack-ptr-mod.cc: ...here. * statistics.c: Moved to... * statistics.cc: ...here. * stmt.c: Moved to... * stmt.cc: ...here. * stor-layout.c: Moved to... * stor-layout.cc: ...here. * store-motion.c: Moved to... * store-motion.cc: ...here. * streamer-hooks.c: Moved to... * streamer-hooks.cc: ...here. * stringpool.c: Moved to... * stringpool.cc: ...here. * substring-locations.c: Moved to... * substring-locations.cc: ...here. * symtab.c: Moved to... * symtab.cc: ...here. * target-globals.c: Moved to... * target-globals.cc: ...here. * targhooks.c: Moved to... * targhooks.cc: ...here. * timevar.c: Moved to... * timevar.cc: ...here. * toplev.c: Moved to... * toplev.cc: ...here. * tracer.c: Moved to... * tracer.cc: ...here. * trans-mem.c: Moved to... * trans-mem.cc: ...here. * tree-affine.c: Moved to... * tree-affine.cc: ...here. * tree-call-cdce.c: Moved to... * tree-call-cdce.cc: ...here. * tree-cfg.c: Moved to... * tree-cfg.cc: ...here. * tree-cfgcleanup.c: Moved to... * tree-cfgcleanup.cc: ...here. * tree-chrec.c: Moved to... * tree-chrec.cc: ...here. * tree-complex.c: Moved to... * tree-complex.cc: ...here. * tree-data-ref.c: Moved to... * tree-data-ref.cc: ...here. * tree-dfa.c: Moved to... * tree-dfa.cc: ...here. * tree-diagnostic.c: Moved to... * tree-diagnostic.cc: ...here. * tree-dump.c: Moved to... * tree-dump.cc: ...here. * tree-eh.c: Moved to... * tree-eh.cc: ...here. * tree-emutls.c: Moved to... * tree-emutls.cc: ...here. * tree-if-conv.c: Moved to... * tree-if-conv.cc: ...here. * tree-inline.c: Moved to... * tree-inline.cc: ...here. * tree-into-ssa.c: Moved to... * tree-into-ssa.cc: ...here. * tree-iterator.c: Moved to... * tree-iterator.cc: ...here. * tree-loop-distribution.c: Moved to... * tree-loop-distribution.cc: ...here. * tree-nested.c: Moved to... * tree-nested.cc: ...here. * tree-nrv.c: Moved to... * tree-nrv.cc: ...here. * tree-object-size.c: Moved to... * tree-object-size.cc: ...here. * tree-outof-ssa.c: Moved to... * tree-outof-ssa.cc: ...here. * tree-parloops.c: Moved to... * tree-parloops.cc: ...here. * tree-phinodes.c: Moved to... * tree-phinodes.cc: ...here. * tree-predcom.c: Moved to... * tree-predcom.cc: ...here. * tree-pretty-print.c: Moved to... * tree-pretty-print.cc: ...here. * tree-profile.c: Moved to... * tree-profile.cc: ...here. * tree-scalar-evolution.c: Moved to... * tree-scalar-evolution.cc: ...here. * tree-sra.c: Moved to... * tree-sra.cc: ...here. * tree-ssa-address.c: Moved to... * tree-ssa-address.cc: ...here. * tree-ssa-alias.c: Moved to... * tree-ssa-alias.cc: ...here. * tree-ssa-ccp.c: Moved to... * tree-ssa-ccp.cc: ...here. * tree-ssa-coalesce.c: Moved to... * tree-ssa-coalesce.cc: ...here. * tree-ssa-copy.c: Moved to... * tree-ssa-copy.cc: ...here. * tree-ssa-dce.c: Moved to... * tree-ssa-dce.cc: ...here. * tree-ssa-dom.c: Moved to... * tree-ssa-dom.cc: ...here. * tree-ssa-dse.c: Moved to... * tree-ssa-dse.cc: ...here. * tree-ssa-forwprop.c: Moved to... * tree-ssa-forwprop.cc: ...here. * tree-ssa-ifcombine.c: Moved to... * tree-ssa-ifcombine.cc: ...here. * tree-ssa-live.c: Moved to... * tree-ssa-live.cc: ...here. * tree-ssa-loop-ch.c: Moved to... * tree-ssa-loop-ch.cc: ...here. * tree-ssa-loop-im.c: Moved to... * tree-ssa-loop-im.cc: ...here. * tree-ssa-loop-ivcanon.c: Moved to... * tree-ssa-loop-ivcanon.cc: ...here. * tree-ssa-loop-ivopts.c: Moved to... * tree-ssa-loop-ivopts.cc: ...here. * tree-ssa-loop-manip.c: Moved to... * tree-ssa-loop-manip.cc: ...here. * tree-ssa-loop-niter.c: Moved to... * tree-ssa-loop-niter.cc: ...here. * tree-ssa-loop-prefetch.c: Moved to... * tree-ssa-loop-prefetch.cc: ...here. * tree-ssa-loop-split.c: Moved to... * tree-ssa-loop-split.cc: ...here. * tree-ssa-loop-unswitch.c: Moved to... * tree-ssa-loop-unswitch.cc: ...here. * tree-ssa-loop.c: Moved to... * tree-ssa-loop.cc: ...here. * tree-ssa-math-opts.c: Moved to... * tree-ssa-math-opts.cc: ...here. * tree-ssa-operands.c: Moved to... * tree-ssa-operands.cc: ...here. * tree-ssa-phiopt.c: Moved to... * tree-ssa-phiopt.cc: ...here. * tree-ssa-phiprop.c: Moved to... * tree-ssa-phiprop.cc: ...here. * tree-ssa-pre.c: Moved to... * tree-ssa-pre.cc: ...here. * tree-ssa-propagate.c: Moved to... * tree-ssa-propagate.cc: ...here. * tree-ssa-reassoc.c: Moved to... * tree-ssa-reassoc.cc: ...here. * tree-ssa-sccvn.c: Moved to... * tree-ssa-sccvn.cc: ...here. * tree-ssa-scopedtables.c: Moved to... * tree-ssa-scopedtables.cc: ...here. * tree-ssa-sink.c: Moved to... * tree-ssa-sink.cc: ...here. * tree-ssa-strlen.c: Moved to... * tree-ssa-strlen.cc: ...here. * tree-ssa-structalias.c: Moved to... * tree-ssa-structalias.cc: ...here. * tree-ssa-tail-merge.c: Moved to... * tree-ssa-tail-merge.cc: ...here. * tree-ssa-ter.c: Moved to... * tree-ssa-ter.cc: ...here. * tree-ssa-threadbackward.c: Moved to... * tree-ssa-threadbackward.cc: ...here. * tree-ssa-threadedge.c: Moved to... * tree-ssa-threadedge.cc: ...here. * tree-ssa-threadupdate.c: Moved to... * tree-ssa-threadupdate.cc: ...here. * tree-ssa-uncprop.c: Moved to... * tree-ssa-uncprop.cc: ...here. * tree-ssa-uninit.c: Moved to... * tree-ssa-uninit.cc: ...here. * tree-ssa.c: Moved to... * tree-ssa.cc: ...here. * tree-ssanames.c: Moved to... * tree-ssanames.cc: ...here. * tree-stdarg.c: Moved to... * tree-stdarg.cc: ...here. * tree-streamer-in.c: Moved to... * tree-streamer-in.cc: ...here. * tree-streamer-out.c: Moved to... * tree-streamer-out.cc: ...here. * tree-streamer.c: Moved to... * tree-streamer.cc: ...here. * tree-switch-conversion.c: Moved to... * tree-switch-conversion.cc: ...here. * tree-tailcall.c: Moved to... * tree-tailcall.cc: ...here. * tree-vect-data-refs.c: Moved to... * tree-vect-data-refs.cc: ...here. * tree-vect-generic.c: Moved to... * tree-vect-generic.cc: ...here. * tree-vect-loop-manip.c: Moved to... * tree-vect-loop-manip.cc: ...here. * tree-vect-loop.c: Moved to... * tree-vect-loop.cc: ...here. * tree-vect-patterns.c: Moved to... * tree-vect-patterns.cc: ...here. * tree-vect-slp-patterns.c: Moved to... * tree-vect-slp-patterns.cc: ...here. * tree-vect-slp.c: Moved to... * tree-vect-slp.cc: ...here. * tree-vect-stmts.c: Moved to... * tree-vect-stmts.cc: ...here. * tree-vector-builder.c: Moved to... * tree-vector-builder.cc: ...here. * tree-vectorizer.c: Moved to... * tree-vectorizer.cc: ...here. * tree-vrp.c: Moved to... * tree-vrp.cc: ...here. * tree.c: Moved to... * tree.cc: ...here. * tsan.c: Moved to... * tsan.cc: ...here. * typed-splay-tree.c: Moved to... * typed-splay-tree.cc: ...here. * ubsan.c: Moved to... * ubsan.cc: ...here. * valtrack.c: Moved to... * valtrack.cc: ...here. * value-prof.c: Moved to... * value-prof.cc: ...here. * var-tracking.c: Moved to... * var-tracking.cc: ...here. * varasm.c: Moved to... * varasm.cc: ...here. * varpool.c: Moved to... * varpool.cc: ...here. * vec-perm-indices.c: Moved to... * vec-perm-indices.cc: ...here. * vec.c: Moved to... * vec.cc: ...here. * vmsdbgout.c: Moved to... * vmsdbgout.cc: ...here. * vr-values.c: Moved to... * vr-values.cc: ...here. * vtable-verify.c: Moved to... * vtable-verify.cc: ...here. * web.c: Moved to... * web.cc: ...here. * xcoffout.c: Moved to... * xcoffout.cc: ...here. gcc/c-family/ChangeLog: * c-ada-spec.c: Moved to... * c-ada-spec.cc: ...here. * c-attribs.c: Moved to... * c-attribs.cc: ...here. * c-common.c: Moved to... * c-common.cc: ...here. * c-cppbuiltin.c: Moved to... * c-cppbuiltin.cc: ...here. * c-dump.c: Moved to... * c-dump.cc: ...here. * c-format.c: Moved to... * c-format.cc: ...here. * c-gimplify.c: Moved to... * c-gimplify.cc: ...here. * c-indentation.c: Moved to... * c-indentation.cc: ...here. * c-lex.c: Moved to... * c-lex.cc: ...here. * c-omp.c: Moved to... * c-omp.cc: ...here. * c-opts.c: Moved to... * c-opts.cc: ...here. * c-pch.c: Moved to... * c-pch.cc: ...here. * c-ppoutput.c: Moved to... * c-ppoutput.cc: ...here. * c-pragma.c: Moved to... * c-pragma.cc: ...here. * c-pretty-print.c: Moved to... * c-pretty-print.cc: ...here. * c-semantics.c: Moved to... * c-semantics.cc: ...here. * c-ubsan.c: Moved to... * c-ubsan.cc: ...here. * c-warn.c: Moved to... * c-warn.cc: ...here. * cppspec.c: Moved to... * cppspec.cc: ...here. * stub-objc.c: Moved to... * stub-objc.cc: ...here. gcc/c/ChangeLog: * c-aux-info.c: Moved to... * c-aux-info.cc: ...here. * c-convert.c: Moved to... * c-convert.cc: ...here. * c-decl.c: Moved to... * c-decl.cc: ...here. * c-errors.c: Moved to... * c-errors.cc: ...here. * c-fold.c: Moved to... * c-fold.cc: ...here. * c-lang.c: Moved to... * c-lang.cc: ...here. * c-objc-common.c: Moved to... * c-objc-common.cc: ...here. * c-parser.c: Moved to... * c-parser.cc: ...here. * c-typeck.c: Moved to... * c-typeck.cc: ...here. * gccspec.c: Moved to... * gccspec.cc: ...here. * gimple-parser.c: Moved to... * gimple-parser.cc: ...here. gcc/cp/ChangeLog: * call.c: Moved to... * call.cc: ...here. * class.c: Moved to... * class.cc: ...here. * constexpr.c: Moved to... * constexpr.cc: ...here. * cp-gimplify.c: Moved to... * cp-gimplify.cc: ...here. * cp-lang.c: Moved to... * cp-lang.cc: ...here. * cp-objcp-common.c: Moved to... * cp-objcp-common.cc: ...here. * cp-ubsan.c: Moved to... * cp-ubsan.cc: ...here. * cvt.c: Moved to... * cvt.cc: ...here. * cxx-pretty-print.c: Moved to... * cxx-pretty-print.cc: ...here. * decl.c: Moved to... * decl.cc: ...here. * decl2.c: Moved to... * decl2.cc: ...here. * dump.c: Moved to... * dump.cc: ...here. * error.c: Moved to... * error.cc: ...here. * except.c: Moved to... * except.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * friend.c: Moved to... * friend.cc: ...here. * g++spec.c: Moved to... * g++spec.cc: ...here. * init.c: Moved to... * init.cc: ...here. * lambda.c: Moved to... * lambda.cc: ...here. * lex.c: Moved to... * lex.cc: ...here. * mangle.c: Moved to... * mangle.cc: ...here. * method.c: Moved to... * method.cc: ...here. * name-lookup.c: Moved to... * name-lookup.cc: ...here. * optimize.c: Moved to... * optimize.cc: ...here. * parser.c: Moved to... * parser.cc: ...here. * pt.c: Moved to... * pt.cc: ...here. * ptree.c: Moved to... * ptree.cc: ...here. * rtti.c: Moved to... * rtti.cc: ...here. * search.c: Moved to... * search.cc: ...here. * semantics.c: Moved to... * semantics.cc: ...here. * tree.c: Moved to... * tree.cc: ...here. * typeck.c: Moved to... * typeck.cc: ...here. * typeck2.c: Moved to... * typeck2.cc: ...here. * vtable-class-hierarchy.c: Moved to... * vtable-class-hierarchy.cc: ...here. gcc/fortran/ChangeLog: * arith.c: Moved to... * arith.cc: ...here. * array.c: Moved to... * array.cc: ...here. * bbt.c: Moved to... * bbt.cc: ...here. * check.c: Moved to... * check.cc: ...here. * class.c: Moved to... * class.cc: ...here. * constructor.c: Moved to... * constructor.cc: ...here. * convert.c: Moved to... * convert.cc: ...here. * cpp.c: Moved to... * cpp.cc: ...here. * data.c: Moved to... * data.cc: ...here. * decl.c: Moved to... * decl.cc: ...here. * dependency.c: Moved to... * dependency.cc: ...here. * dump-parse-tree.c: Moved to... * dump-parse-tree.cc: ...here. * error.c: Moved to... * error.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * f95-lang.c: Moved to... * f95-lang.cc: ...here. * frontend-passes.c: Moved to... * frontend-passes.cc: ...here. * gfortranspec.c: Moved to... * gfortranspec.cc: ...here. * interface.c: Moved to... * interface.cc: ...here. * intrinsic.c: Moved to... * intrinsic.cc: ...here. * io.c: Moved to... * io.cc: ...here. * iresolve.c: Moved to... * iresolve.cc: ...here. * match.c: Moved to... * match.cc: ...here. * matchexp.c: Moved to... * matchexp.cc: ...here. * misc.c: Moved to... * misc.cc: ...here. * module.c: Moved to... * module.cc: ...here. * openmp.c: Moved to... * openmp.cc: ...here. * options.c: Moved to... * options.cc: ...here. * parse.c: Moved to... * parse.cc: ...here. * primary.c: Moved to... * primary.cc: ...here. * resolve.c: Moved to... * resolve.cc: ...here. * scanner.c: Moved to... * scanner.cc: ...here. * simplify.c: Moved to... * simplify.cc: ...here. * st.c: Moved to... * st.cc: ...here. * symbol.c: Moved to... * symbol.cc: ...here. * target-memory.c: Moved to... * target-memory.cc: ...here. * trans-array.c: Moved to... * trans-array.cc: ...here. * trans-common.c: Moved to... * trans-common.cc: ...here. * trans-const.c: Moved to... * trans-const.cc: ...here. * trans-decl.c: Moved to... * trans-decl.cc: ...here. * trans-expr.c: Moved to... * trans-expr.cc: ...here. * trans-intrinsic.c: Moved to... * trans-intrinsic.cc: ...here. * trans-io.c: Moved to... * trans-io.cc: ...here. * trans-openmp.c: Moved to... * trans-openmp.cc: ...here. * trans-stmt.c: Moved to... * trans-stmt.cc: ...here. * trans-types.c: Moved to... * trans-types.cc: ...here. * trans.c: Moved to... * trans.cc: ...here. gcc/go/ChangeLog: * go-backend.c: Moved to... * go-backend.cc: ...here. * go-lang.c: Moved to... * go-lang.cc: ...here. * gospec.c: Moved to... * gospec.cc: ...here. gcc/jit/ChangeLog: * dummy-frontend.c: Moved to... * dummy-frontend.cc: ...here. * jit-builtins.c: Moved to... * jit-builtins.cc: ...here. * jit-logging.c: Moved to... * jit-logging.cc: ...here. * jit-playback.c: Moved to... * jit-playback.cc: ...here. * jit-recording.c: Moved to... * jit-recording.cc: ...here. * jit-result.c: Moved to... * jit-result.cc: ...here. * jit-spec.c: Moved to... * jit-spec.cc: ...here. * jit-tempdir.c: Moved to... * jit-tempdir.cc: ...here. * jit-w32.c: Moved to... * jit-w32.cc: ...here. * libgccjit.c: Moved to... * libgccjit.cc: ...here. gcc/lto/ChangeLog: * common.c: Moved to... * common.cc: ...here. * lto-common.c: Moved to... * lto-common.cc: ...here. * lto-dump.c: Moved to... * lto-dump.cc: ...here. * lto-lang.c: Moved to... * lto-lang.cc: ...here. * lto-object.c: Moved to... * lto-object.cc: ...here. * lto-partition.c: Moved to... * lto-partition.cc: ...here. * lto-symtab.c: Moved to... * lto-symtab.cc: ...here. * lto.c: Moved to... * lto.cc: ...here. gcc/objc/ChangeLog: * objc-act.c: Moved to... * objc-act.cc: ...here. * objc-encoding.c: Moved to... * objc-encoding.cc: ...here. * objc-gnu-runtime-abi-01.c: Moved to... * objc-gnu-runtime-abi-01.cc: ...here. * objc-lang.c: Moved to... * objc-lang.cc: ...here. * objc-map.c: Moved to... * objc-map.cc: ...here. * objc-next-runtime-abi-01.c: Moved to... * objc-next-runtime-abi-01.cc: ...here. * objc-next-runtime-abi-02.c: Moved to... * objc-next-runtime-abi-02.cc: ...here. * objc-runtime-shared-support.c: Moved to... * objc-runtime-shared-support.cc: ...here. gcc/objcp/ChangeLog: * objcp-decl.c: Moved to... * objcp-decl.cc: ...here. * objcp-lang.c: Moved to... * objcp-lang.cc: ...here. libcpp/ChangeLog: * charset.c: Moved to... * charset.cc: ...here. * directives.c: Moved to... * directives.cc: ...here. * errors.c: Moved to... * errors.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * files.c: Moved to... * files.cc: ...here. * identifiers.c: Moved to... * identifiers.cc: ...here. * init.c: Moved to... * init.cc: ...here. * lex.c: Moved to... * lex.cc: ...here. * line-map.c: Moved to... * line-map.cc: ...here. * macro.c: Moved to... * macro.cc: ...here. * makeucnid.c: Moved to... * makeucnid.cc: ...here. * mkdeps.c: Moved to... * mkdeps.cc: ...here. * pch.c: Moved to... * pch.cc: ...here. * symtab.c: Moved to... * symtab.cc: ...here. * traditional.c: Moved to... * traditional.cc: ...here.
Diffstat (limited to 'gcc/fortran/trans-expr.c')
-rw-r--r--gcc/fortran/trans-expr.c12125
1 files changed, 0 insertions, 12125 deletions
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
deleted file mode 100644
index 2e15a7e..0000000
--- a/gcc/fortran/trans-expr.c
+++ /dev/null
@@ -1,12125 +0,0 @@
-/* Expression translation
- Copyright (C) 2002-2022 Free Software Foundation, Inc.
- Contributed by Paul Brook <paul@nowt.org>
- and Steven Bosscher <s.bosscher@student.tudelft.nl>
-
-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/>. */
-
-/* trans-expr.c-- generate GENERIC trees for gfc_expr. */
-
-#include "config.h"
-#include "system.h"
-#include "coretypes.h"
-#include "options.h"
-#include "tree.h"
-#include "gfortran.h"
-#include "trans.h"
-#include "stringpool.h"
-#include "diagnostic-core.h" /* For fatal_error. */
-#include "fold-const.h"
-#include "langhooks.h"
-#include "arith.h"
-#include "constructor.h"
-#include "trans-const.h"
-#include "trans-types.h"
-#include "trans-array.h"
-/* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
-#include "trans-stmt.h"
-#include "dependency.h"
-#include "gimplify.h"
-#include "tm.h" /* For CHAR_TYPE_SIZE. */
-
-
-/* Calculate the number of characters in a string. */
-
-static tree
-gfc_get_character_len (tree type)
-{
- tree len;
-
- gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
- && TYPE_STRING_FLAG (type));
-
- len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
- len = (len) ? (len) : (integer_zero_node);
- return fold_convert (gfc_charlen_type_node, len);
-}
-
-
-
-/* Calculate the number of bytes in a string. */
-
-tree
-gfc_get_character_len_in_bytes (tree type)
-{
- tree tmp, len;
-
- gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
- && TYPE_STRING_FLAG (type));
-
- tmp = TYPE_SIZE_UNIT (TREE_TYPE (type));
- tmp = (tmp && !integer_zerop (tmp))
- ? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE);
- len = gfc_get_character_len (type);
- if (tmp && len && !integer_zerop (len))
- len = fold_build2_loc (input_location, MULT_EXPR,
- gfc_charlen_type_node, len, tmp);
- return len;
-}
-
-
-/* Convert a scalar to an array descriptor. To be used for assumed-rank
- arrays. */
-
-static tree
-get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
-{
- enum gfc_array_kind akind;
-
- if (attr.pointer)
- akind = GFC_ARRAY_POINTER_CONT;
- else if (attr.allocatable)
- akind = GFC_ARRAY_ALLOCATABLE;
- else
- akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
-
- if (POINTER_TYPE_P (TREE_TYPE (scalar)))
- scalar = TREE_TYPE (scalar);
- return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
- akind, !(attr.pointer || attr.target));
-}
-
-tree
-gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
-{
- tree desc, type, etype;
-
- type = get_scalar_to_descriptor_type (scalar, attr);
- etype = TREE_TYPE (scalar);
- desc = gfc_create_var (type, "desc");
- DECL_ARTIFICIAL (desc) = 1;
-
- if (CONSTANT_CLASS_P (scalar))
- {
- tree tmp;
- tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
- gfc_add_modify (&se->pre, tmp, scalar);
- scalar = tmp;
- }
- if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
- scalar = gfc_build_addr_expr (NULL_TREE, scalar);
- else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
- etype = TREE_TYPE (etype);
- gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
- gfc_get_dtype_rank_type (0, etype));
- gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
- gfc_conv_descriptor_span_set (&se->pre, desc,
- gfc_conv_descriptor_elem_len (desc));
-
- /* Copy pointer address back - but only if it could have changed and
- if the actual argument is a pointer and not, e.g., NULL(). */
- if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
- gfc_add_modify (&se->post, scalar,
- fold_convert (TREE_TYPE (scalar),
- gfc_conv_descriptor_data_get (desc)));
- return desc;
-}
-
-
-/* Get the coarray token from the ultimate array or component ref.
- Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
-
-tree
-gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
-{
- gfc_symbol *sym = expr->symtree->n.sym;
- bool is_coarray = sym->attr.codimension;
- gfc_expr *caf_expr = gfc_copy_expr (expr);
- gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
-
- while (ref)
- {
- if (ref->type == REF_COMPONENT
- && (ref->u.c.component->attr.allocatable
- || ref->u.c.component->attr.pointer)
- && (is_coarray || ref->u.c.component->attr.codimension))
- last_caf_ref = ref;
- ref = ref->next;
- }
-
- if (last_caf_ref == NULL)
- return NULL_TREE;
-
- tree comp = last_caf_ref->u.c.component->caf_token, caf;
- gfc_se se;
- bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
- if (comp == NULL_TREE && comp_ref)
- return NULL_TREE;
- gfc_init_se (&se, outerse);
- gfc_free_ref_list (last_caf_ref->next);
- last_caf_ref->next = NULL;
- caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
- se.want_pointer = comp_ref;
- gfc_conv_expr (&se, caf_expr);
- gfc_add_block_to_block (&outerse->pre, &se.pre);
-
- if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
- se.expr = TREE_OPERAND (se.expr, 0);
- gfc_free_expr (caf_expr);
-
- if (comp_ref)
- caf = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (comp), se.expr, comp, NULL_TREE);
- else
- caf = gfc_conv_descriptor_token (se.expr);
- return gfc_build_addr_expr (NULL_TREE, caf);
-}
-
-
-/* This is the seed for an eventual trans-class.c
-
- The following parameters should not be used directly since they might
- in future implementations. Use the corresponding APIs. */
-#define CLASS_DATA_FIELD 0
-#define CLASS_VPTR_FIELD 1
-#define CLASS_LEN_FIELD 2
-#define VTABLE_HASH_FIELD 0
-#define VTABLE_SIZE_FIELD 1
-#define VTABLE_EXTENDS_FIELD 2
-#define VTABLE_DEF_INIT_FIELD 3
-#define VTABLE_COPY_FIELD 4
-#define VTABLE_FINAL_FIELD 5
-#define VTABLE_DEALLOCATE_FIELD 6
-
-
-tree
-gfc_class_set_static_fields (tree decl, tree vptr, tree data)
-{
- tree tmp;
- tree field;
- vec<constructor_elt, va_gc> *init = NULL;
-
- field = TYPE_FIELDS (TREE_TYPE (decl));
- tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
- CONSTRUCTOR_APPEND_ELT (init, tmp, data);
-
- tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
- CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
-
- return build_constructor (TREE_TYPE (decl), init);
-}
-
-
-tree
-gfc_class_data_get (tree decl)
-{
- tree data;
- if (POINTER_TYPE_P (TREE_TYPE (decl)))
- decl = build_fold_indirect_ref_loc (input_location, decl);
- data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
- CLASS_DATA_FIELD);
- return fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (data), decl, data,
- NULL_TREE);
-}
-
-
-tree
-gfc_class_vptr_get (tree decl)
-{
- tree vptr;
- /* For class arrays decl may be a temporary descriptor handle, the vptr is
- then available through the saved descriptor. */
- if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
- && GFC_DECL_SAVED_DESCRIPTOR (decl))
- decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
- if (POINTER_TYPE_P (TREE_TYPE (decl)))
- decl = build_fold_indirect_ref_loc (input_location, decl);
- vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
- CLASS_VPTR_FIELD);
- return fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (vptr), decl, vptr,
- NULL_TREE);
-}
-
-
-tree
-gfc_class_len_get (tree decl)
-{
- tree len;
- /* For class arrays decl may be a temporary descriptor handle, the len is
- then available through the saved descriptor. */
- if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
- && GFC_DECL_SAVED_DESCRIPTOR (decl))
- decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
- if (POINTER_TYPE_P (TREE_TYPE (decl)))
- decl = build_fold_indirect_ref_loc (input_location, decl);
- len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
- CLASS_LEN_FIELD);
- return fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (len), decl, len,
- NULL_TREE);
-}
-
-
-/* Try to get the _len component of a class. When the class is not unlimited
- poly, i.e. no _len field exists, then return a zero node. */
-
-static tree
-gfc_class_len_or_zero_get (tree decl)
-{
- tree len;
- /* For class arrays decl may be a temporary descriptor handle, the vptr is
- then available through the saved descriptor. */
- if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
- && GFC_DECL_SAVED_DESCRIPTOR (decl))
- decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
- if (POINTER_TYPE_P (TREE_TYPE (decl)))
- decl = build_fold_indirect_ref_loc (input_location, decl);
- len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
- CLASS_LEN_FIELD);
- return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (len), decl, len,
- NULL_TREE)
- : build_zero_cst (gfc_charlen_type_node);
-}
-
-
-tree
-gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
-{
- tree tmp;
- tree tmp2;
- tree type;
-
- tmp = gfc_class_len_or_zero_get (class_expr);
-
- /* Include the len value in the element size if present. */
- if (!integer_zerop (tmp))
- {
- type = TREE_TYPE (size);
- if (block)
- {
- size = gfc_evaluate_now (size, block);
- tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
- }
- tmp2 = fold_build2_loc (input_location, MULT_EXPR,
- type, size, tmp);
- tmp = fold_build2_loc (input_location, GT_EXPR,
- logical_type_node, tmp,
- build_zero_cst (type));
- size = fold_build3_loc (input_location, COND_EXPR,
- type, tmp, tmp2, size);
- }
- else
- return size;
-
- if (block)
- size = gfc_evaluate_now (size, block);
-
- return size;
-}
-
-
-/* Get the specified FIELD from the VPTR. */
-
-static tree
-vptr_field_get (tree vptr, int fieldno)
-{
- tree field;
- vptr = build_fold_indirect_ref_loc (input_location, vptr);
- field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
- fieldno);
- field = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field), vptr, field,
- NULL_TREE);
- gcc_assert (field);
- return field;
-}
-
-
-/* Get the field from the class' vptr. */
-
-static tree
-class_vtab_field_get (tree decl, int fieldno)
-{
- tree vptr;
- vptr = gfc_class_vptr_get (decl);
- return vptr_field_get (vptr, fieldno);
-}
-
-
-/* Define a macro for creating the class_vtab_* and vptr_* accessors in
- unison. */
-#define VTAB_GET_FIELD_GEN(name, field) tree \
-gfc_class_vtab_## name ##_get (tree cl) \
-{ \
- return class_vtab_field_get (cl, field); \
-} \
- \
-tree \
-gfc_vptr_## name ##_get (tree vptr) \
-{ \
- return vptr_field_get (vptr, field); \
-}
-
-VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
-VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
-VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
-VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
-VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
-VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
-#undef VTAB_GET_FIELD_GEN
-
-/* The size field is returned as an array index type. Therefore treat
- it and only it specially. */
-
-tree
-gfc_class_vtab_size_get (tree cl)
-{
- tree size;
- size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
- /* Always return size as an array index type. */
- size = fold_convert (gfc_array_index_type, size);
- gcc_assert (size);
- return size;
-}
-
-tree
-gfc_vptr_size_get (tree vptr)
-{
- tree size;
- size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
- /* Always return size as an array index type. */
- size = fold_convert (gfc_array_index_type, size);
- gcc_assert (size);
- return size;
-}
-
-
-#undef CLASS_DATA_FIELD
-#undef CLASS_VPTR_FIELD
-#undef CLASS_LEN_FIELD
-#undef VTABLE_HASH_FIELD
-#undef VTABLE_SIZE_FIELD
-#undef VTABLE_EXTENDS_FIELD
-#undef VTABLE_DEF_INIT_FIELD
-#undef VTABLE_COPY_FIELD
-#undef VTABLE_FINAL_FIELD
-
-
-/* IF ts is null (default), search for the last _class ref in the chain
- of references of the expression and cut the chain there. Although
- this routine is similiar to class.c:gfc_add_component_ref (), there
- is a significant difference: gfc_add_component_ref () concentrates
- on an array ref that is the last ref in the chain and is oblivious
- to the kind of refs following.
- ELSE IF ts is non-null the cut is at the class entity or component
- that is followed by an array reference, which is not an element.
- These calls come from trans-array.c:build_class_array_ref, which
- handles scalarized class array references.*/
-
-gfc_expr *
-gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
- gfc_typespec **ts)
-{
- gfc_expr *base_expr;
- gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
-
- /* Find the last class reference. */
- class_ref = NULL;
- array_ref = NULL;
-
- if (ts)
- {
- if (e->symtree
- && e->symtree->n.sym->ts.type == BT_CLASS)
- *ts = &e->symtree->n.sym->ts;
- else
- *ts = NULL;
- }
-
- for (ref = e->ref; ref; ref = ref->next)
- {
- if (ts)
- {
- if (ref->type == REF_COMPONENT
- && ref->u.c.component->ts.type == BT_CLASS
- && ref->next && ref->next->type == REF_COMPONENT
- && !strcmp (ref->next->u.c.component->name, "_data")
- && ref->next->next
- && ref->next->next->type == REF_ARRAY
- && ref->next->next->u.ar.type != AR_ELEMENT)
- {
- *ts = &ref->u.c.component->ts;
- class_ref = ref;
- break;
- }
-
- if (ref->next == NULL)
- break;
- }
- else
- {
- if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
- array_ref = ref;
-
- if (ref->type == REF_COMPONENT
- && ref->u.c.component->ts.type == BT_CLASS)
- {
- /* Component to the right of a part reference with nonzero
- rank must not have the ALLOCATABLE attribute. If attempts
- are made to reference such a component reference, an error
- results followed by an ICE. */
- if (array_ref
- && CLASS_DATA (ref->u.c.component)->attr.allocatable)
- return NULL;
- class_ref = ref;
- }
- }
- }
-
- if (ts && *ts == NULL)
- return NULL;
-
- /* Remove and store all subsequent references after the
- CLASS reference. */
- if (class_ref)
- {
- tail = class_ref->next;
- class_ref->next = NULL;
- }
- else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
- {
- tail = e->ref;
- e->ref = NULL;
- }
-
- if (is_mold)
- base_expr = gfc_expr_to_initialize (e);
- else
- base_expr = gfc_copy_expr (e);
-
- /* Restore the original tail expression. */
- if (class_ref)
- {
- gfc_free_ref_list (class_ref->next);
- class_ref->next = tail;
- }
- else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
- {
- gfc_free_ref_list (e->ref);
- e->ref = tail;
- }
- return base_expr;
-}
-
-
-/* Reset the vptr to the declared type, e.g. after deallocation. */
-
-void
-gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
-{
- gfc_symbol *vtab;
- tree vptr;
- tree vtable;
- gfc_se se;
-
- /* Evaluate the expression and obtain the vptr from it. */
- gfc_init_se (&se, NULL);
- if (e->rank)
- gfc_conv_expr_descriptor (&se, e);
- else
- gfc_conv_expr (&se, e);
- gfc_add_block_to_block (block, &se.pre);
- vptr = gfc_get_vptr_from_expr (se.expr);
-
- /* If a vptr is not found, we can do nothing more. */
- if (vptr == NULL_TREE)
- return;
-
- if (UNLIMITED_POLY (e))
- gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
- else
- {
- /* Return the vptr to the address of the declared type. */
- vtab = gfc_find_derived_vtab (e->ts.u.derived);
- vtable = vtab->backend_decl;
- if (vtable == NULL_TREE)
- vtable = gfc_get_symbol_decl (vtab);
- vtable = gfc_build_addr_expr (NULL, vtable);
- vtable = fold_convert (TREE_TYPE (vptr), vtable);
- gfc_add_modify (block, vptr, vtable);
- }
-}
-
-
-/* Reset the len for unlimited polymorphic objects. */
-
-void
-gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
-{
- gfc_expr *e;
- gfc_se se_len;
- e = gfc_find_and_cut_at_last_class_ref (expr);
- if (e == NULL)
- return;
- gfc_add_len_component (e);
- gfc_init_se (&se_len, NULL);
- gfc_conv_expr (&se_len, e);
- gfc_add_modify (block, se_len.expr,
- fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
- gfc_free_expr (e);
-}
-
-
-/* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class
- reference is found. Note that it is up to the caller to avoid using this
- for expressions other than variables. */
-
-tree
-gfc_get_class_from_gfc_expr (gfc_expr *e)
-{
- gfc_expr *class_expr;
- gfc_se cse;
- class_expr = gfc_find_and_cut_at_last_class_ref (e);
- if (class_expr == NULL)
- return NULL_TREE;
- gfc_init_se (&cse, NULL);
- gfc_conv_expr (&cse, class_expr);
- gfc_free_expr (class_expr);
- return cse.expr;
-}
-
-
-/* Obtain the last class reference in an expression.
- Return NULL_TREE if no class reference is found. */
-
-tree
-gfc_get_class_from_expr (tree expr)
-{
- tree tmp;
- tree type;
-
- for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
- {
- if (CONSTANT_CLASS_P (tmp))
- return NULL_TREE;
-
- type = TREE_TYPE (tmp);
- while (type)
- {
- if (GFC_CLASS_TYPE_P (type))
- return tmp;
- if (type != TYPE_CANONICAL (type))
- type = TYPE_CANONICAL (type);
- else
- type = NULL_TREE;
- }
- if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
- break;
- }
-
- if (POINTER_TYPE_P (TREE_TYPE (tmp)))
- tmp = build_fold_indirect_ref_loc (input_location, tmp);
-
- if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
- return tmp;
-
- return NULL_TREE;
-}
-
-
-/* Obtain the vptr of the last class reference in an expression.
- Return NULL_TREE if no class reference is found. */
-
-tree
-gfc_get_vptr_from_expr (tree expr)
-{
- tree tmp;
-
- tmp = gfc_get_class_from_expr (expr);
-
- if (tmp != NULL_TREE)
- return gfc_class_vptr_get (tmp);
-
- return NULL_TREE;
-}
-
-
-static void
-class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
- bool lhs_type)
-{
- tree tmp, tmp2, type;
-
- gfc_conv_descriptor_data_set (block, lhs_desc,
- gfc_conv_descriptor_data_get (rhs_desc));
- gfc_conv_descriptor_offset_set (block, lhs_desc,
- gfc_conv_descriptor_offset_get (rhs_desc));
-
- gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
- gfc_conv_descriptor_dtype (rhs_desc));
-
- /* Assign the dimension as range-ref. */
- tmp = gfc_get_descriptor_dimension (lhs_desc);
- tmp2 = gfc_get_descriptor_dimension (rhs_desc);
-
- type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
- tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
- gfc_index_zero_node, NULL_TREE, NULL_TREE);
- tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
- gfc_index_zero_node, NULL_TREE, NULL_TREE);
- gfc_add_modify (block, tmp, tmp2);
-}
-
-
-/* Takes a derived type expression and returns the address of a temporary
- class object of the 'declared' type. If vptr is not NULL, this is
- used for the temporary class object.
- optional_alloc_ptr is false when the dummy is neither allocatable
- nor a pointer; that's only relevant for the optional handling.
- The optional argument 'derived_array' is used to preserve the parmse
- expression for deallocation of allocatable components. Assumed rank
- formal arguments made this necessary. */
-void
-gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
- gfc_typespec class_ts, tree vptr, bool optional,
- bool optional_alloc_ptr,
- tree *derived_array)
-{
- gfc_symbol *vtab;
- tree cond_optional = NULL_TREE;
- gfc_ss *ss;
- tree ctree;
- tree var;
- tree tmp;
- int dim;
-
- /* The derived type needs to be converted to a temporary
- CLASS object. */
- tmp = gfc_typenode_for_spec (&class_ts);
- var = gfc_create_var (tmp, "class");
-
- /* Set the vptr. */
- ctree = gfc_class_vptr_get (var);
-
- if (vptr != NULL_TREE)
- {
- /* Use the dynamic vptr. */
- tmp = vptr;
- }
- else
- {
- /* In this case the vtab corresponds to the derived type and the
- vptr must point to it. */
- vtab = gfc_find_derived_vtab (e->ts.u.derived);
- gcc_assert (vtab);
- tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
- }
- gfc_add_modify (&parmse->pre, ctree,
- fold_convert (TREE_TYPE (ctree), tmp));
-
- /* Now set the data field. */
- ctree = gfc_class_data_get (var);
-
- if (optional)
- cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
-
- if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
- {
- /* If there is a ready made pointer to a derived type, use it
- rather than evaluating the expression again. */
- tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
- gfc_add_modify (&parmse->pre, ctree, tmp);
- }
- else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
- {
- /* For an array reference in an elemental procedure call we need
- to retain the ss to provide the scalarized array reference. */
- gfc_conv_expr_reference (parmse, e);
- tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
- if (optional)
- tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
- cond_optional, tmp,
- fold_convert (TREE_TYPE (tmp), null_pointer_node));
- gfc_add_modify (&parmse->pre, ctree, tmp);
- }
- else
- {
- ss = gfc_walk_expr (e);
- if (ss == gfc_ss_terminator)
- {
- parmse->ss = NULL;
- gfc_conv_expr_reference (parmse, e);
-
- /* Scalar to an assumed-rank array. */
- if (class_ts.u.derived->components->as)
- {
- tree type;
- type = get_scalar_to_descriptor_type (parmse->expr,
- gfc_expr_attr (e));
- gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
- gfc_get_dtype (type));
- if (optional)
- parmse->expr = build3_loc (input_location, COND_EXPR,
- TREE_TYPE (parmse->expr),
- cond_optional, parmse->expr,
- fold_convert (TREE_TYPE (parmse->expr),
- null_pointer_node));
- gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
- }
- else
- {
- tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
- if (optional)
- tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
- cond_optional, tmp,
- fold_convert (TREE_TYPE (tmp),
- null_pointer_node));
- gfc_add_modify (&parmse->pre, ctree, tmp);
- }
- }
- else
- {
- stmtblock_t block;
- gfc_init_block (&block);
- gfc_ref *ref;
-
- parmse->ss = ss;
- parmse->use_offset = 1;
- gfc_conv_expr_descriptor (parmse, e);
-
- /* Detect any array references with vector subscripts. */
- for (ref = e->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY
- && ref->u.ar.type != AR_ELEMENT
- && ref->u.ar.type != AR_FULL)
- {
- for (dim = 0; dim < ref->u.ar.dimen; dim++)
- if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
- break;
- if (dim < ref->u.ar.dimen)
- break;
- }
-
- /* Array references with vector subscripts and non-variable expressions
- need be converted to a one-based descriptor. */
- if (ref || e->expr_type != EXPR_VARIABLE)
- {
- for (dim = 0; dim < e->rank; ++dim)
- gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim,
- gfc_index_one_node);
- }
-
- if (e->rank != class_ts.u.derived->components->as->rank)
- {
- gcc_assert (class_ts.u.derived->components->as->type
- == AS_ASSUMED_RANK);
- if (derived_array
- && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
- {
- *derived_array = gfc_create_var (TREE_TYPE (parmse->expr),
- "array");
- gfc_add_modify (&block, *derived_array , parmse->expr);
- }
- class_array_data_assign (&block, ctree, parmse->expr, false);
- }
- else
- {
- if (gfc_expr_attr (e).codimension)
- parmse->expr = fold_build1_loc (input_location,
- VIEW_CONVERT_EXPR,
- TREE_TYPE (ctree),
- parmse->expr);
- gfc_add_modify (&block, ctree, parmse->expr);
- }
-
- if (optional)
- {
- tmp = gfc_finish_block (&block);
-
- gfc_init_block (&block);
- gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
- if (derived_array && *derived_array != NULL_TREE)
- gfc_conv_descriptor_data_set (&block, *derived_array,
- null_pointer_node);
-
- tmp = build3_v (COND_EXPR, cond_optional, tmp,
- gfc_finish_block (&block));
- gfc_add_expr_to_block (&parmse->pre, tmp);
- }
- else
- gfc_add_block_to_block (&parmse->pre, &block);
- }
- }
-
- if (class_ts.u.derived->components->ts.type == BT_DERIVED
- && class_ts.u.derived->components->ts.u.derived
- ->attr.unlimited_polymorphic)
- {
- /* Take care about initializing the _len component correctly. */
- ctree = gfc_class_len_get (var);
- if (UNLIMITED_POLY (e))
- {
- gfc_expr *len;
- gfc_se se;
-
- len = gfc_find_and_cut_at_last_class_ref (e);
- gfc_add_len_component (len);
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, len);
- if (optional)
- tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
- cond_optional, se.expr,
- fold_convert (TREE_TYPE (se.expr),
- integer_zero_node));
- else
- tmp = se.expr;
- gfc_free_expr (len);
- }
- else
- tmp = integer_zero_node;
- gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree),
- tmp));
- }
- /* Pass the address of the class object. */
- parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
-
- if (optional && optional_alloc_ptr)
- parmse->expr = build3_loc (input_location, COND_EXPR,
- TREE_TYPE (parmse->expr),
- cond_optional, parmse->expr,
- fold_convert (TREE_TYPE (parmse->expr),
- null_pointer_node));
-}
-
-
-/* Create a new class container, which is required as scalar coarrays
- have an array descriptor while normal scalars haven't. Optionally,
- NULL pointer checks are added if the argument is OPTIONAL. */
-
-static void
-class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
- gfc_typespec class_ts, bool optional)
-{
- tree var, ctree, tmp;
- stmtblock_t block;
- gfc_ref *ref;
- gfc_ref *class_ref;
-
- gfc_init_block (&block);
-
- class_ref = NULL;
- for (ref = e->ref; ref; ref = ref->next)
- {
- if (ref->type == REF_COMPONENT
- && ref->u.c.component->ts.type == BT_CLASS)
- class_ref = ref;
- }
-
- if (class_ref == NULL
- && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
- tmp = e->symtree->n.sym->backend_decl;
- else
- {
- /* Remove everything after the last class reference, convert the
- expression and then recover its tailend once more. */
- gfc_se tmpse;
- ref = class_ref->next;
- class_ref->next = NULL;
- gfc_init_se (&tmpse, NULL);
- gfc_conv_expr (&tmpse, e);
- class_ref->next = ref;
- tmp = tmpse.expr;
- }
-
- var = gfc_typenode_for_spec (&class_ts);
- var = gfc_create_var (var, "class");
-
- ctree = gfc_class_vptr_get (var);
- gfc_add_modify (&block, ctree,
- fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
-
- ctree = gfc_class_data_get (var);
- tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
- gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
-
- /* Pass the address of the class object. */
- parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
-
- if (optional)
- {
- tree cond = gfc_conv_expr_present (e->symtree->n.sym);
- tree tmp2;
-
- tmp = gfc_finish_block (&block);
-
- gfc_init_block (&block);
- tmp2 = gfc_class_data_get (var);
- gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
- null_pointer_node));
- tmp2 = gfc_finish_block (&block);
-
- tmp = build3_loc (input_location, COND_EXPR, void_type_node,
- cond, tmp, tmp2);
- gfc_add_expr_to_block (&parmse->pre, tmp);
- }
- else
- gfc_add_block_to_block (&parmse->pre, &block);
-}
-
-
-/* Takes an intrinsic type expression and returns the address of a temporary
- class object of the 'declared' type. */
-void
-gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
- gfc_typespec class_ts)
-{
- gfc_symbol *vtab;
- gfc_ss *ss;
- tree ctree;
- tree var;
- tree tmp;
- int dim;
-
- /* The intrinsic type needs to be converted to a temporary
- CLASS object. */
- tmp = gfc_typenode_for_spec (&class_ts);
- var = gfc_create_var (tmp, "class");
-
- /* Set the vptr. */
- ctree = gfc_class_vptr_get (var);
-
- vtab = gfc_find_vtab (&e->ts);
- gcc_assert (vtab);
- tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
- gfc_add_modify (&parmse->pre, ctree,
- fold_convert (TREE_TYPE (ctree), tmp));
-
- /* Now set the data field. */
- ctree = gfc_class_data_get (var);
- if (parmse->ss && parmse->ss->info->useflags)
- {
- /* For an array reference in an elemental procedure call we need
- to retain the ss to provide the scalarized array reference. */
- gfc_conv_expr_reference (parmse, e);
- tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
- gfc_add_modify (&parmse->pre, ctree, tmp);
- }
- else
- {
- ss = gfc_walk_expr (e);
- if (ss == gfc_ss_terminator)
- {
- parmse->ss = NULL;
- gfc_conv_expr_reference (parmse, e);
- if (class_ts.u.derived->components->as
- && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
- {
- tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
- gfc_expr_attr (e));
- tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
- TREE_TYPE (ctree), tmp);
- }
- else
- tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
- gfc_add_modify (&parmse->pre, ctree, tmp);
- }
- else
- {
- parmse->ss = ss;
- parmse->use_offset = 1;
- gfc_conv_expr_descriptor (parmse, e);
-
- /* Array references with vector subscripts and non-variable expressions
- need be converted to a one-based descriptor. */
- if (e->expr_type != EXPR_VARIABLE)
- {
- for (dim = 0; dim < e->rank; ++dim)
- gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr,
- dim, gfc_index_one_node);
- }
-
- if (class_ts.u.derived->components->as->rank != e->rank)
- {
- tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
- TREE_TYPE (ctree), parmse->expr);
- gfc_add_modify (&parmse->pre, ctree, tmp);
- }
- else
- gfc_add_modify (&parmse->pre, ctree, parmse->expr);
- }
- }
-
- gcc_assert (class_ts.type == BT_CLASS);
- if (class_ts.u.derived->components->ts.type == BT_DERIVED
- && class_ts.u.derived->components->ts.u.derived
- ->attr.unlimited_polymorphic)
- {
- ctree = gfc_class_len_get (var);
- /* When the actual arg is a char array, then set the _len component of the
- unlimited polymorphic entity to the length of the string. */
- if (e->ts.type == BT_CHARACTER)
- {
- /* Start with parmse->string_length because this seems to be set to a
- correct value more often. */
- if (parmse->string_length)
- tmp = parmse->string_length;
- /* When the string_length is not yet set, then try the backend_decl of
- the cl. */
- else if (e->ts.u.cl->backend_decl)
- tmp = e->ts.u.cl->backend_decl;
- /* If both of the above approaches fail, then try to generate an
- expression from the input, which is only feasible currently, when the
- expression can be evaluated to a constant one. */
- else
- {
- /* Try to simplify the expression. */
- gfc_simplify_expr (e, 0);
- if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
- {
- /* Amazingly all data is present to compute the length of a
- constant string, but the expression is not yet there. */
- e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
- gfc_charlen_int_kind,
- &e->where);
- mpz_set_ui (e->ts.u.cl->length->value.integer,
- e->value.character.length);
- gfc_conv_const_charlen (e->ts.u.cl);
- e->ts.u.cl->resolved = 1;
- tmp = e->ts.u.cl->backend_decl;
- }
- else
- {
- gfc_error ("Cannot compute the length of the char array "
- "at %L.", &e->where);
- }
- }
- }
- else
- tmp = integer_zero_node;
-
- gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
- }
- else if (class_ts.type == BT_CLASS
- && class_ts.u.derived->components
- && class_ts.u.derived->components->ts.u
- .derived->attr.unlimited_polymorphic)
- {
- ctree = gfc_class_len_get (var);
- gfc_add_modify (&parmse->pre, ctree,
- fold_convert (TREE_TYPE (ctree),
- integer_zero_node));
- }
- /* Pass the address of the class object. */
- parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
-}
-
-
-/* Takes a scalarized class array expression and returns the
- address of a temporary scalar class object of the 'declared'
- type.
- OOP-TODO: This could be improved by adding code that branched on
- the dynamic type being the same as the declared type. In this case
- the original class expression can be passed directly.
- optional_alloc_ptr is false when the dummy is neither allocatable
- nor a pointer; that's relevant for the optional handling.
- Set copyback to true if class container's _data and _vtab pointers
- might get modified. */
-
-void
-gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
- bool elemental, bool copyback, bool optional,
- bool optional_alloc_ptr)
-{
- tree ctree;
- tree var;
- tree tmp;
- tree vptr;
- tree cond = NULL_TREE;
- tree slen = NULL_TREE;
- gfc_ref *ref;
- gfc_ref *class_ref;
- stmtblock_t block;
- bool full_array = false;
-
- gfc_init_block (&block);
-
- class_ref = NULL;
- for (ref = e->ref; ref; ref = ref->next)
- {
- if (ref->type == REF_COMPONENT
- && ref->u.c.component->ts.type == BT_CLASS)
- class_ref = ref;
-
- if (ref->next == NULL)
- break;
- }
-
- if ((ref == NULL || class_ref == ref)
- && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
- && (!class_ts.u.derived->components->as
- || class_ts.u.derived->components->as->rank != -1))
- return;
-
- /* Test for FULL_ARRAY. */
- if (e->rank == 0 && gfc_expr_attr (e).codimension
- && gfc_expr_attr (e).dimension)
- full_array = true;
- else
- gfc_is_class_array_ref (e, &full_array);
-
- /* The derived type needs to be converted to a temporary
- CLASS object. */
- tmp = gfc_typenode_for_spec (&class_ts);
- var = gfc_create_var (tmp, "class");
-
- /* Set the data. */
- ctree = gfc_class_data_get (var);
- if (class_ts.u.derived->components->as
- && e->rank != class_ts.u.derived->components->as->rank)
- {
- if (e->rank == 0)
- {
- tree type = get_scalar_to_descriptor_type (parmse->expr,
- gfc_expr_attr (e));
- gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
- gfc_get_dtype (type));
-
- tmp = gfc_class_data_get (parmse->expr);
- if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
-
- gfc_conv_descriptor_data_set (&block, ctree, tmp);
- }
- else
- class_array_data_assign (&block, ctree, parmse->expr, false);
- }
- else
- {
- if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
- parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
- TREE_TYPE (ctree), parmse->expr);
- gfc_add_modify (&block, ctree, parmse->expr);
- }
-
- /* Return the data component, except in the case of scalarized array
- references, where nullification of the cannot occur and so there
- is no need. */
- if (!elemental && full_array && copyback)
- {
- if (class_ts.u.derived->components->as
- && e->rank != class_ts.u.derived->components->as->rank)
- {
- if (e->rank == 0)
- gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr),
- gfc_conv_descriptor_data_get (ctree));
- else
- class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
- }
- else
- gfc_add_modify (&parmse->post, parmse->expr, ctree);
- }
-
- /* Set the vptr. */
- ctree = gfc_class_vptr_get (var);
-
- /* The vptr is the second field of the actual argument.
- First we have to find the corresponding class reference. */
-
- tmp = NULL_TREE;
- if (gfc_is_class_array_function (e)
- && parmse->class_vptr != NULL_TREE)
- tmp = parmse->class_vptr;
- else if (class_ref == NULL
- && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
- {
- tmp = e->symtree->n.sym->backend_decl;
-
- if (TREE_CODE (tmp) == FUNCTION_DECL)
- tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
-
- if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
- tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
-
- slen = build_zero_cst (size_type_node);
- }
- else
- {
- /* Remove everything after the last class reference, convert the
- expression and then recover its tailend once more. */
- gfc_se tmpse;
- ref = class_ref->next;
- class_ref->next = NULL;
- gfc_init_se (&tmpse, NULL);
- gfc_conv_expr (&tmpse, e);
- class_ref->next = ref;
- tmp = tmpse.expr;
- slen = tmpse.string_length;
- }
-
- gcc_assert (tmp != NULL_TREE);
-
- /* Dereference if needs be. */
- if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
- tmp = build_fold_indirect_ref_loc (input_location, tmp);
-
- if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
- vptr = gfc_class_vptr_get (tmp);
- else
- vptr = tmp;
-
- gfc_add_modify (&block, ctree,
- fold_convert (TREE_TYPE (ctree), vptr));
-
- /* Return the vptr component, except in the case of scalarized array
- references, where the dynamic type cannot change. */
- if (!elemental && full_array && copyback)
- gfc_add_modify (&parmse->post, vptr,
- fold_convert (TREE_TYPE (vptr), ctree));
-
- /* For unlimited polymorphic objects also set the _len component. */
- if (class_ts.type == BT_CLASS
- && class_ts.u.derived->components
- && class_ts.u.derived->components->ts.u
- .derived->attr.unlimited_polymorphic)
- {
- ctree = gfc_class_len_get (var);
- if (UNLIMITED_POLY (e))
- tmp = gfc_class_len_get (tmp);
- else if (e->ts.type == BT_CHARACTER)
- {
- gcc_assert (slen != NULL_TREE);
- tmp = slen;
- }
- else
- tmp = build_zero_cst (size_type_node);
- gfc_add_modify (&parmse->pre, ctree,
- fold_convert (TREE_TYPE (ctree), tmp));
-
- /* Return the len component, except in the case of scalarized array
- references, where the dynamic type cannot change. */
- if (!elemental && full_array && copyback
- && (UNLIMITED_POLY (e) || VAR_P (tmp)))
- gfc_add_modify (&parmse->post, tmp,
- fold_convert (TREE_TYPE (tmp), ctree));
- }
-
- if (optional)
- {
- tree tmp2;
-
- cond = gfc_conv_expr_present (e->symtree->n.sym);
- /* parmse->pre may contain some preparatory instructions for the
- temporary array descriptor. Those may only be executed when the
- optional argument is set, therefore add parmse->pre's instructions
- to block, which is later guarded by an if (optional_arg_given). */
- gfc_add_block_to_block (&parmse->pre, &block);
- block.head = parmse->pre.head;
- parmse->pre.head = NULL_TREE;
- tmp = gfc_finish_block (&block);
-
- if (optional_alloc_ptr)
- tmp2 = build_empty_stmt (input_location);
- else
- {
- gfc_init_block (&block);
-
- tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
- gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
- null_pointer_node));
- tmp2 = gfc_finish_block (&block);
- }
-
- tmp = build3_loc (input_location, COND_EXPR, void_type_node,
- cond, tmp, tmp2);
- gfc_add_expr_to_block (&parmse->pre, tmp);
- }
- else
- gfc_add_block_to_block (&parmse->pre, &block);
-
- /* Pass the address of the class object. */
- parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
-
- if (optional && optional_alloc_ptr)
- parmse->expr = build3_loc (input_location, COND_EXPR,
- TREE_TYPE (parmse->expr),
- cond, parmse->expr,
- fold_convert (TREE_TYPE (parmse->expr),
- null_pointer_node));
-}
-
-
-/* Given a class array declaration and an index, returns the address
- of the referenced element. */
-
-static tree
-gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
- bool unlimited)
-{
- tree data, size, tmp, ctmp, offset, ptr;
-
- data = data_comp != NULL_TREE ? data_comp :
- gfc_class_data_get (class_decl);
- size = gfc_class_vtab_size_get (class_decl);
-
- if (unlimited)
- {
- tmp = fold_convert (gfc_array_index_type,
- gfc_class_len_get (class_decl));
- ctmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, size, tmp);
- tmp = fold_build2_loc (input_location, GT_EXPR,
- logical_type_node, tmp,
- build_zero_cst (TREE_TYPE (tmp)));
- size = fold_build3_loc (input_location, COND_EXPR,
- gfc_array_index_type, tmp, ctmp, size);
- }
-
- offset = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type,
- index, size);
-
- data = gfc_conv_descriptor_data_get (data);
- ptr = fold_convert (pvoid_type_node, data);
- ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
- return fold_convert (TREE_TYPE (data), ptr);
-}
-
-
-/* Copies one class expression to another, assuming that if either
- 'to' or 'from' are arrays they are packed. Should 'from' be
- NULL_TREE, the initialization expression for 'to' is used, assuming
- that the _vptr is set. */
-
-tree
-gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
-{
- tree fcn;
- tree fcn_type;
- tree from_data;
- tree from_len;
- tree to_data;
- tree to_len;
- tree to_ref;
- tree from_ref;
- vec<tree, va_gc> *args;
- tree tmp;
- tree stdcopy;
- tree extcopy;
- tree index;
- bool is_from_desc = false, is_to_class = false;
-
- args = NULL;
- /* To prevent warnings on uninitialized variables. */
- from_len = to_len = NULL_TREE;
-
- if (from != NULL_TREE)
- fcn = gfc_class_vtab_copy_get (from);
- else
- fcn = gfc_class_vtab_copy_get (to);
-
- fcn_type = TREE_TYPE (TREE_TYPE (fcn));
-
- if (from != NULL_TREE)
- {
- is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
- if (is_from_desc)
- {
- from_data = from;
- from = GFC_DECL_SAVED_DESCRIPTOR (from);
- }
- else
- {
- /* Check that from is a class. When the class is part of a coarray,
- then from is a common pointer and is to be used as is. */
- tmp = POINTER_TYPE_P (TREE_TYPE (from))
- ? build_fold_indirect_ref (from) : from;
- from_data =
- (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
- || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
- ? gfc_class_data_get (from) : from;
- is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
- }
- }
- else
- from_data = gfc_class_vtab_def_init_get (to);
-
- if (unlimited)
- {
- if (from != NULL_TREE && unlimited)
- from_len = gfc_class_len_or_zero_get (from);
- else
- from_len = build_zero_cst (size_type_node);
- }
-
- if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
- {
- is_to_class = true;
- to_data = gfc_class_data_get (to);
- if (unlimited)
- to_len = gfc_class_len_get (to);
- }
- else
- /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
- to_data = to;
-
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
- {
- stmtblock_t loopbody;
- stmtblock_t body;
- stmtblock_t ifbody;
- gfc_loopinfo loop;
- tree orig_nelems = nelems; /* Needed for bounds check. */
-
- gfc_init_block (&body);
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, nelems,
- gfc_index_one_node);
- nelems = gfc_evaluate_now (tmp, &body);
- index = gfc_create_var (gfc_array_index_type, "S");
-
- if (is_from_desc)
- {
- from_ref = gfc_get_class_array_ref (index, from, from_data,
- unlimited);
- vec_safe_push (args, from_ref);
- }
- else
- vec_safe_push (args, from_data);
-
- if (is_to_class)
- to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
- else
- {
- tmp = gfc_conv_array_data (to);
- tmp = build_fold_indirect_ref_loc (input_location, tmp);
- to_ref = gfc_build_addr_expr (NULL_TREE,
- gfc_build_array_ref (tmp, index, to));
- }
- vec_safe_push (args, to_ref);
-
- /* Add bounds check. */
- if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
- {
- char *msg;
- const char *name = "<<unknown>>";
- tree from_len;
-
- if (DECL_P (to))
- name = (const char *)(DECL_NAME (to)->identifier.id.str);
-
- from_len = gfc_conv_descriptor_size (from_data, 1);
- tmp = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node, from_len, orig_nelems);
- msg = xasprintf ("Array bound mismatch for dimension %d "
- "of array '%s' (%%ld/%%ld)",
- 1, name);
-
- gfc_trans_runtime_check (true, false, tmp, &body,
- &gfc_current_locus, msg,
- fold_convert (long_integer_type_node, orig_nelems),
- fold_convert (long_integer_type_node, from_len));
-
- free (msg);
- }
-
- tmp = build_call_vec (fcn_type, fcn, args);
-
- /* Build the body of the loop. */
- gfc_init_block (&loopbody);
- gfc_add_expr_to_block (&loopbody, tmp);
-
- /* Build the loop and return. */
- gfc_init_loopinfo (&loop);
- loop.dimen = 1;
- loop.from[0] = gfc_index_zero_node;
- loop.loopvar[0] = index;
- loop.to[0] = nelems;
- gfc_trans_scalarizing_loops (&loop, &loopbody);
- gfc_init_block (&ifbody);
- gfc_add_block_to_block (&ifbody, &loop.pre);
- stdcopy = gfc_finish_block (&ifbody);
- /* In initialization mode from_len is a constant zero. */
- if (unlimited && !integer_zerop (from_len))
- {
- vec_safe_push (args, from_len);
- vec_safe_push (args, to_len);
- tmp = build_call_vec (fcn_type, fcn, args);
- /* Build the body of the loop. */
- gfc_init_block (&loopbody);
- gfc_add_expr_to_block (&loopbody, tmp);
-
- /* Build the loop and return. */
- gfc_init_loopinfo (&loop);
- loop.dimen = 1;
- loop.from[0] = gfc_index_zero_node;
- loop.loopvar[0] = index;
- loop.to[0] = nelems;
- gfc_trans_scalarizing_loops (&loop, &loopbody);
- gfc_init_block (&ifbody);
- gfc_add_block_to_block (&ifbody, &loop.pre);
- extcopy = gfc_finish_block (&ifbody);
-
- tmp = fold_build2_loc (input_location, GT_EXPR,
- logical_type_node, from_len,
- build_zero_cst (TREE_TYPE (from_len)));
- tmp = fold_build3_loc (input_location, COND_EXPR,
- void_type_node, tmp, extcopy, stdcopy);
- gfc_add_expr_to_block (&body, tmp);
- tmp = gfc_finish_block (&body);
- }
- else
- {
- gfc_add_expr_to_block (&body, stdcopy);
- tmp = gfc_finish_block (&body);
- }
- gfc_cleanup_loop (&loop);
- }
- else
- {
- gcc_assert (!is_from_desc);
- vec_safe_push (args, from_data);
- vec_safe_push (args, to_data);
- stdcopy = build_call_vec (fcn_type, fcn, args);
-
- /* In initialization mode from_len is a constant zero. */
- if (unlimited && !integer_zerop (from_len))
- {
- vec_safe_push (args, from_len);
- vec_safe_push (args, to_len);
- extcopy = build_call_vec (fcn_type, unshare_expr (fcn), args);
- tmp = fold_build2_loc (input_location, GT_EXPR,
- logical_type_node, from_len,
- build_zero_cst (TREE_TYPE (from_len)));
- tmp = fold_build3_loc (input_location, COND_EXPR,
- void_type_node, tmp, extcopy, stdcopy);
- }
- else
- tmp = stdcopy;
- }
-
- /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
- if (from == NULL_TREE)
- {
- tree cond;
- cond = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node,
- from_data, null_pointer_node);
- tmp = fold_build3_loc (input_location, COND_EXPR,
- void_type_node, cond,
- tmp, build_empty_stmt (input_location));
- }
-
- return tmp;
-}
-
-
-static tree
-gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
-{
- gfc_actual_arglist *actual;
- gfc_expr *ppc;
- gfc_code *ppc_code;
- tree res;
-
- actual = gfc_get_actual_arglist ();
- actual->expr = gfc_copy_expr (rhs);
- actual->next = gfc_get_actual_arglist ();
- actual->next->expr = gfc_copy_expr (lhs);
- ppc = gfc_copy_expr (obj);
- gfc_add_vptr_component (ppc);
- gfc_add_component_ref (ppc, "_copy");
- ppc_code = gfc_get_code (EXEC_CALL);
- ppc_code->resolved_sym = ppc->symtree->n.sym;
- /* Although '_copy' is set to be elemental in class.c, it is
- not staying that way. Find out why, sometime.... */
- ppc_code->resolved_sym->attr.elemental = 1;
- ppc_code->ext.actual = actual;
- ppc_code->expr1 = ppc;
- /* Since '_copy' is elemental, the scalarizer will take care
- of arrays in gfc_trans_call. */
- res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
- gfc_free_statements (ppc_code);
-
- if (UNLIMITED_POLY(obj))
- {
- /* Check if rhs is non-NULL. */
- gfc_se src;
- gfc_init_se (&src, NULL);
- gfc_conv_expr (&src, rhs);
- src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
- tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
- src.expr, fold_convert (TREE_TYPE (src.expr),
- null_pointer_node));
- res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
- build_empty_stmt (input_location));
- }
-
- return res;
-}
-
-/* Special case for initializing a polymorphic dummy with INTENT(OUT).
- A MEMCPY is needed to copy the full data from the default initializer
- of the dynamic type. */
-
-tree
-gfc_trans_class_init_assign (gfc_code *code)
-{
- stmtblock_t block;
- tree tmp;
- gfc_se dst,src,memsz;
- gfc_expr *lhs, *rhs, *sz;
-
- gfc_start_block (&block);
-
- lhs = gfc_copy_expr (code->expr1);
-
- rhs = gfc_copy_expr (code->expr1);
- gfc_add_vptr_component (rhs);
-
- /* Make sure that the component backend_decls have been built, which
- will not have happened if the derived types concerned have not
- been referenced. */
- gfc_get_derived_type (rhs->ts.u.derived);
- gfc_add_def_init_component (rhs);
- /* The _def_init is always scalar. */
- rhs->rank = 0;
-
- if (code->expr1->ts.type == BT_CLASS
- && CLASS_DATA (code->expr1)->attr.dimension)
- {
- gfc_array_spec *tmparr = gfc_get_array_spec ();
- *tmparr = *CLASS_DATA (code->expr1)->as;
- /* Adding the array ref to the class expression results in correct
- indexing to the dynamic type. */
- gfc_add_full_array_ref (lhs, tmparr);
- tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
- }
- else
- {
- /* Scalar initialization needs the _data component. */
- gfc_add_data_component (lhs);
- sz = gfc_copy_expr (code->expr1);
- gfc_add_vptr_component (sz);
- gfc_add_size_component (sz);
-
- gfc_init_se (&dst, NULL);
- gfc_init_se (&src, NULL);
- gfc_init_se (&memsz, NULL);
- gfc_conv_expr (&dst, lhs);
- gfc_conv_expr (&src, rhs);
- gfc_conv_expr (&memsz, sz);
- gfc_add_block_to_block (&block, &src.pre);
- src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
-
- tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
-
- if (UNLIMITED_POLY(code->expr1))
- {
- /* Check if _def_init is non-NULL. */
- tree cond = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node, src.expr,
- fold_convert (TREE_TYPE (src.expr),
- null_pointer_node));
- tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
- tmp, build_empty_stmt (input_location));
- }
- }
-
- if (code->expr1->symtree->n.sym->attr.dummy
- && (code->expr1->symtree->n.sym->attr.optional
- || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master))
- {
- tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
- tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
- present, tmp,
- build_empty_stmt (input_location));
- }
-
- gfc_add_expr_to_block (&block, tmp);
-
- return gfc_finish_block (&block);
-}
-
-
-/* Class valued elemental function calls or class array elements arriving
- in gfc_trans_scalar_assign come here. Wherever possible the vptr copy
- is used to ensure that the rhs dynamic type is assigned to the lhs. */
-
-static bool
-trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse)
-{
- tree fcn;
- tree rse_expr;
- tree class_data;
- tree tmp;
- tree zero;
- tree cond;
- tree final_cond;
- stmtblock_t inner_block;
- bool is_descriptor;
- bool not_call_expr = TREE_CODE (rse->expr) != CALL_EXPR;
- bool not_lhs_array_type;
-
- /* Temporaries arising from depencies in assignment get cast as a
- character type of the dynamic size of the rhs. Use the vptr copy
- for this case. */
- tmp = TREE_TYPE (lse->expr);
- not_lhs_array_type = !(tmp && TREE_CODE (tmp) == ARRAY_TYPE
- && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) != NULL_TREE);
-
- /* Use ordinary assignment if the rhs is not a call expression or
- the lhs is not a class entity or an array(ie. character) type. */
- if ((not_call_expr && gfc_get_class_from_expr (lse->expr) == NULL_TREE)
- && not_lhs_array_type)
- return false;
-
- /* Ordinary assignment can be used if both sides are class expressions
- since the dynamic type is preserved by copying the vptr. This
- should only occur, where temporaries are involved. */
- if (GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
- && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
- return false;
-
- /* Fix the class expression and the class data of the rhs. */
- if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
- || not_call_expr)
- {
- tmp = gfc_get_class_from_expr (rse->expr);
- if (tmp == NULL_TREE)
- return false;
- rse_expr = gfc_evaluate_now (tmp, block);
- }
- else
- rse_expr = gfc_evaluate_now (rse->expr, block);
-
- class_data = gfc_class_data_get (rse_expr);
-
- /* Check that the rhs data is not null. */
- is_descriptor = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data));
- if (is_descriptor)
- class_data = gfc_conv_descriptor_data_get (class_data);
- class_data = gfc_evaluate_now (class_data, block);
-
- zero = build_int_cst (TREE_TYPE (class_data), 0);
- cond = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node,
- class_data, zero);
-
- /* Copy the rhs to the lhs. */
- fcn = gfc_vptr_copy_get (gfc_class_vptr_get (rse_expr));
- fcn = build_fold_indirect_ref_loc (input_location, fcn);
- tmp = gfc_evaluate_now (gfc_build_addr_expr (NULL, rse->expr), block);
- tmp = is_descriptor ? tmp : class_data;
- tmp = build_call_expr_loc (input_location, fcn, 2, tmp,
- gfc_build_addr_expr (NULL, lse->expr));
- gfc_add_expr_to_block (block, tmp);
-
- /* Only elemental function results need to be finalised and freed. */
- if (not_call_expr)
- return true;
-
- /* Finalize the class data if needed. */
- gfc_init_block (&inner_block);
- fcn = gfc_vptr_final_get (gfc_class_vptr_get (rse_expr));
- zero = build_int_cst (TREE_TYPE (fcn), 0);
- final_cond = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node, fcn, zero);
- fcn = build_fold_indirect_ref_loc (input_location, fcn);
- tmp = build_call_expr_loc (input_location, fcn, 1, class_data);
- tmp = build3_v (COND_EXPR, final_cond,
- tmp, build_empty_stmt (input_location));
- gfc_add_expr_to_block (&inner_block, tmp);
-
- /* Free the class data. */
- tmp = gfc_call_free (class_data);
- tmp = build3_v (COND_EXPR, cond, tmp,
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&inner_block, tmp);
-
- /* Finish the inner block and subject it to the condition on the
- class data being non-zero. */
- tmp = gfc_finish_block (&inner_block);
- tmp = build3_v (COND_EXPR, cond, tmp,
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (block, tmp);
-
- return true;
-}
-
-/* End of prototype trans-class.c */
-
-
-static void
-realloc_lhs_warning (bt type, bool array, locus *where)
-{
- if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
- gfc_warning (OPT_Wrealloc_lhs,
- "Code for reallocating the allocatable array at %L will "
- "be added", where);
- else if (warn_realloc_lhs_all)
- gfc_warning (OPT_Wrealloc_lhs_all,
- "Code for reallocating the allocatable variable at %L "
- "will be added", where);
-}
-
-
-static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
- gfc_expr *);
-
-/* Copy the scalarization loop variables. */
-
-static void
-gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
-{
- dest->ss = src->ss;
- dest->loop = src->loop;
-}
-
-
-/* Initialize a simple expression holder.
-
- Care must be taken when multiple se are created with the same parent.
- The child se must be kept in sync. The easiest way is to delay creation
- of a child se until after the previous se has been translated. */
-
-void
-gfc_init_se (gfc_se * se, gfc_se * parent)
-{
- memset (se, 0, sizeof (gfc_se));
- gfc_init_block (&se->pre);
- gfc_init_block (&se->post);
-
- se->parent = parent;
-
- if (parent)
- gfc_copy_se_loopvars (se, parent);
-}
-
-
-/* Advances to the next SS in the chain. Use this rather than setting
- se->ss = se->ss->next because all the parents needs to be kept in sync.
- See gfc_init_se. */
-
-void
-gfc_advance_se_ss_chain (gfc_se * se)
-{
- gfc_se *p;
- gfc_ss *ss;
-
- gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
-
- p = se;
- /* Walk down the parent chain. */
- while (p != NULL)
- {
- /* Simple consistency check. */
- gcc_assert (p->parent == NULL || p->parent->ss == p->ss
- || p->parent->ss->nested_ss == p->ss);
-
- /* If we were in a nested loop, the next scalarized expression can be
- on the parent ss' next pointer. Thus we should not take the next
- pointer blindly, but rather go up one nest level as long as next
- is the end of chain. */
- ss = p->ss;
- while (ss->next == gfc_ss_terminator && ss->parent != NULL)
- ss = ss->parent;
-
- p->ss = ss->next;
-
- p = p->parent;
- }
-}
-
-
-/* Ensures the result of the expression as either a temporary variable
- or a constant so that it can be used repeatedly. */
-
-void
-gfc_make_safe_expr (gfc_se * se)
-{
- tree var;
-
- if (CONSTANT_CLASS_P (se->expr))
- return;
-
- /* We need a temporary for this result. */
- var = gfc_create_var (TREE_TYPE (se->expr), NULL);
- gfc_add_modify (&se->pre, var, se->expr);
- se->expr = var;
-}
-
-
-/* Return an expression which determines if a dummy parameter is present.
- Also used for arguments to procedures with multiple entry points. */
-
-tree
-gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc)
-{
- tree decl, orig_decl, cond;
-
- gcc_assert (sym->attr.dummy);
- orig_decl = decl = gfc_get_symbol_decl (sym);
-
- /* Intrinsic scalars with VALUE attribute which are passed by value
- use a hidden argument to denote the present status. */
- if (sym->attr.value && sym->ts.type != BT_CHARACTER
- && sym->ts.type != BT_CLASS && sym->ts.type != BT_DERIVED
- && !sym->attr.dimension)
- {
- char name[GFC_MAX_SYMBOL_LEN + 2];
- tree tree_name;
-
- gcc_assert (TREE_CODE (decl) == PARM_DECL);
- name[0] = '_';
- strcpy (&name[1], sym->name);
- tree_name = get_identifier (name);
-
- /* Walk function argument list to find hidden arg. */
- cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
- for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
- if (DECL_NAME (cond) == tree_name
- && DECL_ARTIFICIAL (cond))
- break;
-
- gcc_assert (cond);
- return cond;
- }
-
- /* Assumed-shape arrays use a local variable for the array data;
- the actual PARAM_DECL is in a saved decl. As the local variable
- is NULL, it can be checked instead, unless use_saved_desc is
- requested. */
-
- if (use_saved_desc && TREE_CODE (decl) != PARM_DECL)
- {
- gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
- || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
- decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
- }
-
- cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
- fold_convert (TREE_TYPE (decl), null_pointer_node));
-
- /* Fortran 2008 allows to pass null pointers and non-associated pointers
- as actual argument to denote absent dummies. For array descriptors,
- we thus also need to check the array descriptor. For BT_CLASS, it
- can also occur for scalars and F2003 due to type->class wrapping and
- class->class wrapping. Note further that BT_CLASS always uses an
- array descriptor for arrays, also for explicit-shape/assumed-size.
- For assumed-rank arrays, no local variable is generated, hence,
- the following also applies with !use_saved_desc. */
-
- if ((use_saved_desc || TREE_CODE (orig_decl) == PARM_DECL)
- && !sym->attr.allocatable
- && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
- || (sym->ts.type == BT_CLASS
- && !CLASS_DATA (sym)->attr.allocatable
- && !CLASS_DATA (sym)->attr.class_pointer))
- && ((gfc_option.allow_std & GFC_STD_F2008) != 0
- || sym->ts.type == BT_CLASS))
- {
- tree tmp;
-
- if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
- || sym->as->type == AS_ASSUMED_RANK
- || sym->attr.codimension))
- || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
- {
- tmp = build_fold_indirect_ref_loc (input_location, decl);
- if (sym->ts.type == BT_CLASS)
- tmp = gfc_class_data_get (tmp);
- tmp = gfc_conv_array_data (tmp);
- }
- else if (sym->ts.type == BT_CLASS)
- tmp = gfc_class_data_get (decl);
- else
- tmp = NULL_TREE;
-
- if (tmp != NULL_TREE)
- {
- tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
- fold_convert (TREE_TYPE (tmp), null_pointer_node));
- cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
- logical_type_node, cond, tmp);
- }
- }
-
- return cond;
-}
-
-
-/* Converts a missing, dummy argument into a null or zero. */
-
-void
-gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
-{
- tree present;
- tree tmp;
-
- present = gfc_conv_expr_present (arg->symtree->n.sym);
-
- if (kind > 0)
- {
- /* Create a temporary and convert it to the correct type. */
- tmp = gfc_get_int_type (kind);
- tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
- se->expr));
-
- /* Test for a NULL value. */
- tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
- tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
- tmp = gfc_evaluate_now (tmp, &se->pre);
- se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
- }
- else
- {
- tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
- present, se->expr,
- build_zero_cst (TREE_TYPE (se->expr)));
- tmp = gfc_evaluate_now (tmp, &se->pre);
- se->expr = tmp;
- }
-
- if (ts.type == BT_CHARACTER)
- {
- tmp = build_int_cst (gfc_charlen_type_node, 0);
- tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
- present, se->string_length, tmp);
- tmp = gfc_evaluate_now (tmp, &se->pre);
- se->string_length = tmp;
- }
- return;
-}
-
-
-/* Get the character length of an expression, looking through gfc_refs
- if necessary. */
-
-tree
-gfc_get_expr_charlen (gfc_expr *e)
-{
- gfc_ref *r;
- tree length;
- gfc_se se;
-
- gcc_assert (e->expr_type == EXPR_VARIABLE
- && e->ts.type == BT_CHARACTER);
-
- length = NULL; /* To silence compiler warning. */
-
- if (is_subref_array (e) && e->ts.u.cl->length)
- {
- gfc_se tmpse;
- gfc_init_se (&tmpse, NULL);
- gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
- e->ts.u.cl->backend_decl = tmpse.expr;
- return tmpse.expr;
- }
-
- /* First candidate: if the variable is of type CHARACTER, the
- expression's length could be the length of the character
- variable. */
- if (e->symtree->n.sym->ts.type == BT_CHARACTER)
- length = e->symtree->n.sym->ts.u.cl->backend_decl;
-
- /* Look through the reference chain for component references. */
- for (r = e->ref; r; r = r->next)
- {
- switch (r->type)
- {
- case REF_COMPONENT:
- if (r->u.c.component->ts.type == BT_CHARACTER)
- length = r->u.c.component->ts.u.cl->backend_decl;
- break;
-
- case REF_ARRAY:
- /* Do nothing. */
- break;
-
- case REF_SUBSTRING:
- gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node);
- length = se.expr;
- gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
- length = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_charlen_type_node,
- se.expr, length);
- length = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_charlen_type_node, length,
- gfc_index_one_node);
- break;
-
- default:
- gcc_unreachable ();
- break;
- }
- }
-
- gcc_assert (length != NULL);
- return length;
-}
-
-
-/* Return for an expression the backend decl of the coarray. */
-
-tree
-gfc_get_tree_for_caf_expr (gfc_expr *expr)
-{
- tree caf_decl;
- bool found = false;
- gfc_ref *ref;
-
- gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
-
- /* Not-implemented diagnostic. */
- if (expr->symtree->n.sym->ts.type == BT_CLASS
- && UNLIMITED_POLY (expr->symtree->n.sym)
- && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
- gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
- "%L is not supported", &expr->where);
-
- for (ref = expr->ref; ref; ref = ref->next)
- if (ref->type == REF_COMPONENT)
- {
- if (ref->u.c.component->ts.type == BT_CLASS
- && UNLIMITED_POLY (ref->u.c.component)
- && CLASS_DATA (ref->u.c.component)->attr.codimension)
- gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
- "component at %L is not supported", &expr->where);
- }
-
- /* Make sure the backend_decl is present before accessing it. */
- caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
- ? gfc_get_symbol_decl (expr->symtree->n.sym)
- : expr->symtree->n.sym->backend_decl;
-
- if (expr->symtree->n.sym->ts.type == BT_CLASS)
- {
- if (expr->ref && expr->ref->type == REF_ARRAY)
- {
- caf_decl = gfc_class_data_get (caf_decl);
- if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
- return caf_decl;
- }
- for (ref = expr->ref; ref; ref = ref->next)
- {
- if (ref->type == REF_COMPONENT
- && strcmp (ref->u.c.component->name, "_data") != 0)
- {
- caf_decl = gfc_class_data_get (caf_decl);
- if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
- return caf_decl;
- break;
- }
- else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
- break;
- }
- }
- if (expr->symtree->n.sym->attr.codimension)
- return caf_decl;
-
- /* The following code assumes that the coarray is a component reachable via
- only scalar components/variables; the Fortran standard guarantees this. */
-
- for (ref = expr->ref; ref; ref = ref->next)
- if (ref->type == REF_COMPONENT)
- {
- gfc_component *comp = ref->u.c.component;
-
- if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
- caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
- caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (comp->backend_decl), caf_decl,
- comp->backend_decl, NULL_TREE);
- if (comp->ts.type == BT_CLASS)
- {
- caf_decl = gfc_class_data_get (caf_decl);
- if (CLASS_DATA (comp)->attr.codimension)
- {
- found = true;
- break;
- }
- }
- if (comp->attr.codimension)
- {
- found = true;
- break;
- }
- }
- gcc_assert (found && caf_decl);
- return caf_decl;
-}
-
-
-/* Obtain the Coarray token - and optionally also the offset. */
-
-void
-gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
- tree se_expr, gfc_expr *expr)
-{
- tree tmp;
-
- /* Coarray token. */
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
- {
- gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))
- == GFC_ARRAY_ALLOCATABLE
- || expr->symtree->n.sym->attr.select_type_temporary);
- *token = gfc_conv_descriptor_token (caf_decl);
- }
- else if (DECL_LANG_SPECIFIC (caf_decl)
- && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
- *token = GFC_DECL_TOKEN (caf_decl);
- else
- {
- gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
- && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
- *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
- }
-
- if (offset == NULL)
- return;
-
- /* Offset between the coarray base address and the address wanted. */
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
- && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
- || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
- *offset = build_int_cst (gfc_array_index_type, 0);
- else if (DECL_LANG_SPECIFIC (caf_decl)
- && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
- *offset = GFC_DECL_CAF_OFFSET (caf_decl);
- else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
- *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
- else
- *offset = build_int_cst (gfc_array_index_type, 0);
-
- if (POINTER_TYPE_P (TREE_TYPE (se_expr))
- && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
- {
- tmp = build_fold_indirect_ref_loc (input_location, se_expr);
- tmp = gfc_conv_descriptor_data_get (tmp);
- }
- else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
- tmp = gfc_conv_descriptor_data_get (se_expr);
- else
- {
- gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
- tmp = se_expr;
- }
-
- *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- *offset, fold_convert (gfc_array_index_type, tmp));
-
- if (expr->symtree->n.sym->ts.type == BT_DERIVED
- && expr->symtree->n.sym->attr.codimension
- && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
- {
- gfc_expr *base_expr = gfc_copy_expr (expr);
- gfc_ref *ref = base_expr->ref;
- gfc_se base_se;
-
- // Iterate through the refs until the last one.
- while (ref->next)
- ref = ref->next;
-
- if (ref->type == REF_ARRAY
- && ref->u.ar.type != AR_FULL)
- {
- const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
- int i;
- for (i = 0; i < ranksum; ++i)
- {
- ref->u.ar.start[i] = NULL;
- ref->u.ar.end[i] = NULL;
- }
- ref->u.ar.type = AR_FULL;
- }
- gfc_init_se (&base_se, NULL);
- if (gfc_caf_attr (base_expr).dimension)
- {
- gfc_conv_expr_descriptor (&base_se, base_expr);
- tmp = gfc_conv_descriptor_data_get (base_se.expr);
- }
- else
- {
- gfc_conv_expr (&base_se, base_expr);
- tmp = base_se.expr;
- }
-
- gfc_free_expr (base_expr);
- gfc_add_block_to_block (&se->pre, &base_se.pre);
- gfc_add_block_to_block (&se->post, &base_se.post);
- }
- else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
- tmp = gfc_conv_descriptor_data_get (caf_decl);
- else
- {
- gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
- tmp = caf_decl;
- }
-
- *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- fold_convert (gfc_array_index_type, *offset),
- fold_convert (gfc_array_index_type, tmp));
-}
-
-
-/* Convert the coindex of a coarray into an image index; the result is
- image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
- + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
-
-tree
-gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
-{
- gfc_ref *ref;
- tree lbound, ubound, extent, tmp, img_idx;
- gfc_se se;
- int i;
-
- for (ref = e->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
- break;
- gcc_assert (ref != NULL);
-
- if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
- {
- return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
- integer_zero_node);
- }
-
- img_idx = build_zero_cst (gfc_array_index_type);
- extent = build_one_cst (gfc_array_index_type);
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
- for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
- {
- gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
- gfc_add_block_to_block (block, &se.pre);
- lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- TREE_TYPE (lbound), se.expr, lbound);
- tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
- extent, tmp);
- img_idx = fold_build2_loc (input_location, PLUS_EXPR,
- TREE_TYPE (tmp), img_idx, tmp);
- if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
- {
- ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
- tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
- extent = fold_build2_loc (input_location, MULT_EXPR,
- TREE_TYPE (tmp), extent, tmp);
- }
- }
- else
- for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
- {
- gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
- gfc_add_block_to_block (block, &se.pre);
- lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- TREE_TYPE (lbound), se.expr, lbound);
- tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
- extent, tmp);
- img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
- img_idx, tmp);
- if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
- {
- ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- TREE_TYPE (ubound), ubound, lbound);
- tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
- tmp, build_one_cst (TREE_TYPE (tmp)));
- extent = fold_build2_loc (input_location, MULT_EXPR,
- TREE_TYPE (tmp), extent, tmp);
- }
- }
- img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx),
- img_idx, build_one_cst (TREE_TYPE (img_idx)));
- return fold_convert (integer_type_node, img_idx);
-}
-
-
-/* For each character array constructor subexpression without a ts.u.cl->length,
- replace it by its first element (if there aren't any elements, the length
- should already be set to zero). */
-
-static void
-flatten_array_ctors_without_strlen (gfc_expr* e)
-{
- gfc_actual_arglist* arg;
- gfc_constructor* c;
-
- if (!e)
- return;
-
- switch (e->expr_type)
- {
-
- case EXPR_OP:
- flatten_array_ctors_without_strlen (e->value.op.op1);
- flatten_array_ctors_without_strlen (e->value.op.op2);
- break;
-
- case EXPR_COMPCALL:
- /* TODO: Implement as with EXPR_FUNCTION when needed. */
- gcc_unreachable ();
-
- case EXPR_FUNCTION:
- for (arg = e->value.function.actual; arg; arg = arg->next)
- flatten_array_ctors_without_strlen (arg->expr);
- break;
-
- case EXPR_ARRAY:
-
- /* We've found what we're looking for. */
- if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
- {
- gfc_constructor *c;
- gfc_expr* new_expr;
-
- gcc_assert (e->value.constructor);
-
- c = gfc_constructor_first (e->value.constructor);
- new_expr = c->expr;
- c->expr = NULL;
-
- flatten_array_ctors_without_strlen (new_expr);
- gfc_replace_expr (e, new_expr);
- break;
- }
-
- /* Otherwise, fall through to handle constructor elements. */
- gcc_fallthrough ();
- case EXPR_STRUCTURE:
- for (c = gfc_constructor_first (e->value.constructor);
- c; c = gfc_constructor_next (c))
- flatten_array_ctors_without_strlen (c->expr);
- break;
-
- default:
- break;
-
- }
-}
-
-
-/* Generate code to initialize a string length variable. Returns the
- value. For array constructors, cl->length might be NULL and in this case,
- the first element of the constructor is needed. expr is the original
- expression so we can access it but can be NULL if this is not needed. */
-
-void
-gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
-{
- gfc_se se;
-
- gfc_init_se (&se, NULL);
-
- if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
- return;
-
- /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
- "flatten" array constructors by taking their first element; all elements
- should be the same length or a cl->length should be present. */
- if (!cl->length)
- {
- gfc_expr* expr_flat;
- if (!expr)
- return;
- expr_flat = gfc_copy_expr (expr);
- flatten_array_ctors_without_strlen (expr_flat);
- gfc_resolve_expr (expr_flat);
-
- gfc_conv_expr (&se, expr_flat);
- gfc_add_block_to_block (pblock, &se.pre);
- cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
-
- gfc_free_expr (expr_flat);
- return;
- }
-
- /* Convert cl->length. */
-
- gcc_assert (cl->length);
-
- gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
- se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
- se.expr, build_zero_cst (TREE_TYPE (se.expr)));
- gfc_add_block_to_block (pblock, &se.pre);
-
- if (cl->backend_decl && VAR_P (cl->backend_decl))
- gfc_add_modify (pblock, cl->backend_decl, se.expr);
- else
- cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
-}
-
-
-static void
-gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
- const char *name, locus *where)
-{
- tree tmp;
- tree type;
- tree fault;
- gfc_se start;
- gfc_se end;
- char *msg;
- mpz_t length;
-
- type = gfc_get_character_type (kind, ref->u.ss.length);
- type = build_pointer_type (type);
-
- gfc_init_se (&start, se);
- gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
- gfc_add_block_to_block (&se->pre, &start.pre);
-
- if (integer_onep (start.expr))
- gfc_conv_string_parameter (se);
- else
- {
- tmp = start.expr;
- STRIP_NOPS (tmp);
- /* Avoid multiple evaluation of substring start. */
- if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
- start.expr = gfc_evaluate_now (start.expr, &se->pre);
-
- /* Change the start of the string. */
- if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
- || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
- && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
- tmp = se->expr;
- else
- tmp = build_fold_indirect_ref_loc (input_location,
- se->expr);
- /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
- if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
- {
- tmp = gfc_build_array_ref (tmp, start.expr, NULL);
- se->expr = gfc_build_addr_expr (type, tmp);
- }
- }
-
- /* Length = end + 1 - start. */
- gfc_init_se (&end, se);
- if (ref->u.ss.end == NULL)
- end.expr = se->string_length;
- else
- {
- gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
- gfc_add_block_to_block (&se->pre, &end.pre);
- }
- tmp = end.expr;
- STRIP_NOPS (tmp);
- if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
- end.expr = gfc_evaluate_now (end.expr, &se->pre);
-
- if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
- && (ref->u.ss.start->symtree
- && !ref->u.ss.start->symtree->n.sym->attr.implied_index))
- {
- tree nonempty = fold_build2_loc (input_location, LE_EXPR,
- logical_type_node, start.expr,
- end.expr);
-
- /* Check lower bound. */
- fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
- start.expr,
- build_one_cst (TREE_TYPE (start.expr)));
- fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
- logical_type_node, nonempty, fault);
- if (name)
- msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
- "is less than one", name);
- else
- msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
- "is less than one");
- gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
- fold_convert (long_integer_type_node,
- start.expr));
- free (msg);
-
- /* Check upper bound. */
- fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
- end.expr, se->string_length);
- fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
- logical_type_node, nonempty, fault);
- if (name)
- msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
- "exceeds string length (%%ld)", name);
- else
- msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
- "exceeds string length (%%ld)");
- gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
- fold_convert (long_integer_type_node, end.expr),
- fold_convert (long_integer_type_node,
- se->string_length));
- free (msg);
- }
-
- /* Try to calculate the length from the start and end expressions. */
- if (ref->u.ss.end
- && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
- {
- HOST_WIDE_INT i_len;
-
- i_len = gfc_mpz_get_hwi (length) + 1;
- if (i_len < 0)
- i_len = 0;
-
- tmp = build_int_cst (gfc_charlen_type_node, i_len);
- mpz_clear (length); /* Was initialized by gfc_dep_difference. */
- }
- else
- {
- tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
- fold_convert (gfc_charlen_type_node, end.expr),
- fold_convert (gfc_charlen_type_node, start.expr));
- tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
- build_int_cst (gfc_charlen_type_node, 1), tmp);
- tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
- tmp, build_int_cst (gfc_charlen_type_node, 0));
- }
-
- se->string_length = tmp;
-}
-
-
-/* Convert a derived type component reference. */
-
-void
-gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
-{
- gfc_component *c;
- tree tmp;
- tree decl;
- tree field;
- tree context;
-
- c = ref->u.c.component;
-
- if (c->backend_decl == NULL_TREE
- && ref->u.c.sym != NULL)
- gfc_get_derived_type (ref->u.c.sym);
-
- field = c->backend_decl;
- gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
- decl = se->expr;
- context = DECL_FIELD_CONTEXT (field);
-
- /* Components can correspond to fields of different containing
- types, as components are created without context, whereas
- a concrete use of a component has the type of decl as context.
- So, if the type doesn't match, we search the corresponding
- FIELD_DECL in the parent type. To not waste too much time
- we cache this result in norestrict_decl.
- On the other hand, if the context is a UNION or a MAP (a
- RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
-
- if (context != TREE_TYPE (decl)
- && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
- || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
- {
- tree f2 = c->norestrict_decl;
- if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
- for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
- if (TREE_CODE (f2) == FIELD_DECL
- && DECL_NAME (f2) == DECL_NAME (field))
- break;
- gcc_assert (f2);
- c->norestrict_decl = f2;
- field = f2;
- }
-
- if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
- && strcmp ("_data", c->name) == 0)
- {
- /* Found a ref to the _data component. Store the associated ref to
- the vptr in se->class_vptr. */
- se->class_vptr = gfc_class_vptr_get (decl);
- }
- else
- se->class_vptr = NULL_TREE;
-
- tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
- decl, field, NULL_TREE);
-
- se->expr = tmp;
-
- /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
- strlen () conditional below. */
- if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
- && !c->ts.deferred
- && !c->attr.pdt_string)
- {
- tmp = c->ts.u.cl->backend_decl;
- /* Components must always be constant length. */
- gcc_assert (tmp && INTEGER_CST_P (tmp));
- se->string_length = tmp;
- }
-
- if (gfc_deferred_strlen (c, &field))
- {
- tmp = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field),
- decl, field, NULL_TREE);
- se->string_length = tmp;
- }
-
- if (((c->attr.pointer || c->attr.allocatable)
- && (!c->attr.dimension && !c->attr.codimension)
- && c->ts.type != BT_CHARACTER)
- || c->attr.proc_pointer)
- se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
-}
-
-
-/* This function deals with component references to components of the
- parent type for derived type extensions. */
-void
-conv_parent_component_references (gfc_se * se, gfc_ref * ref)
-{
- gfc_component *c;
- gfc_component *cmp;
- gfc_symbol *dt;
- gfc_ref parent;
-
- dt = ref->u.c.sym;
- c = ref->u.c.component;
-
- /* Return if the component is in the parent type. */
- for (cmp = dt->components; cmp; cmp = cmp->next)
- if (strcmp (c->name, cmp->name) == 0)
- return;
-
- /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
- parent.type = REF_COMPONENT;
- parent.next = NULL;
- parent.u.c.sym = dt;
- parent.u.c.component = dt->components;
-
- if (dt->backend_decl == NULL)
- gfc_get_derived_type (dt);
-
- /* Build the reference and call self. */
- gfc_conv_component_ref (se, &parent);
- parent.u.c.sym = dt->components->ts.u.derived;
- parent.u.c.component = c;
- conv_parent_component_references (se, &parent);
-}
-
-
-static void
-conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
-{
- tree res = se->expr;
-
- switch (ref->u.i)
- {
- case INQUIRY_RE:
- res = fold_build1_loc (input_location, REALPART_EXPR,
- TREE_TYPE (TREE_TYPE (res)), res);
- break;
-
- case INQUIRY_IM:
- res = fold_build1_loc (input_location, IMAGPART_EXPR,
- TREE_TYPE (TREE_TYPE (res)), res);
- break;
-
- case INQUIRY_KIND:
- res = build_int_cst (gfc_typenode_for_spec (&expr->ts),
- ts->kind);
- break;
-
- case INQUIRY_LEN:
- res = fold_convert (gfc_typenode_for_spec (&expr->ts),
- se->string_length);
- break;
-
- default:
- gcc_unreachable ();
- }
- se->expr = res;
-}
-
-/* Dereference VAR where needed if it is a pointer, reference, etc.
- according to Fortran semantics. */
-
-tree
-gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
- bool is_classarray)
-{
- if (is_CFI_desc (sym, NULL))
- return build_fold_indirect_ref_loc (input_location, var);
-
- /* Characters are entirely different from other types, they are treated
- separately. */
- if (sym->ts.type == BT_CHARACTER)
- {
- /* Dereference character pointer dummy arguments
- or results. */
- if ((sym->attr.pointer || sym->attr.allocatable
- || (sym->as && sym->as->type == AS_ASSUMED_RANK))
- && (sym->attr.dummy
- || sym->attr.function
- || sym->attr.result))
- var = build_fold_indirect_ref_loc (input_location, var);
- }
- else if (!sym->attr.value)
- {
- /* Dereference temporaries for class array dummy arguments. */
- if (sym->attr.dummy && is_classarray
- && GFC_ARRAY_TYPE_P (TREE_TYPE (var)))
- {
- if (!descriptor_only_p)
- var = GFC_DECL_SAVED_DESCRIPTOR (var);
-
- var = build_fold_indirect_ref_loc (input_location, var);
- }
-
- /* Dereference non-character scalar dummy arguments. */
- if (sym->attr.dummy && !sym->attr.dimension
- && !(sym->attr.codimension && sym->attr.allocatable)
- && (sym->ts.type != BT_CLASS
- || (!CLASS_DATA (sym)->attr.dimension
- && !(CLASS_DATA (sym)->attr.codimension
- && CLASS_DATA (sym)->attr.allocatable))))
- var = build_fold_indirect_ref_loc (input_location, var);
-
- /* Dereference scalar hidden result. */
- if (flag_f2c && sym->ts.type == BT_COMPLEX
- && (sym->attr.function || sym->attr.result)
- && !sym->attr.dimension && !sym->attr.pointer
- && !sym->attr.always_explicit)
- var = build_fold_indirect_ref_loc (input_location, var);
-
- /* Dereference non-character, non-class pointer variables.
- These must be dummies, results, or scalars. */
- if (!is_classarray
- && (sym->attr.pointer || sym->attr.allocatable
- || gfc_is_associate_pointer (sym)
- || (sym->as && sym->as->type == AS_ASSUMED_RANK))
- && (sym->attr.dummy
- || sym->attr.function
- || sym->attr.result
- || (!sym->attr.dimension
- && (!sym->attr.codimension || !sym->attr.allocatable))))
- var = build_fold_indirect_ref_loc (input_location, var);
- /* Now treat the class array pointer variables accordingly. */
- else if (sym->ts.type == BT_CLASS
- && sym->attr.dummy
- && (CLASS_DATA (sym)->attr.dimension
- || CLASS_DATA (sym)->attr.codimension)
- && ((CLASS_DATA (sym)->as
- && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
- || CLASS_DATA (sym)->attr.allocatable
- || CLASS_DATA (sym)->attr.class_pointer))
- var = build_fold_indirect_ref_loc (input_location, var);
- /* And the case where a non-dummy, non-result, non-function,
- non-allotable and non-pointer classarray is present. This case was
- previously covered by the first if, but with introducing the
- condition !is_classarray there, that case has to be covered
- explicitly. */
- else if (sym->ts.type == BT_CLASS
- && !sym->attr.dummy
- && !sym->attr.function
- && !sym->attr.result
- && (CLASS_DATA (sym)->attr.dimension
- || CLASS_DATA (sym)->attr.codimension)
- && (sym->assoc
- || !CLASS_DATA (sym)->attr.allocatable)
- && !CLASS_DATA (sym)->attr.class_pointer)
- var = build_fold_indirect_ref_loc (input_location, var);
- }
-
- return var;
-}
-
-/* Return the contents of a variable. Also handles reference/pointer
- variables (all Fortran pointer references are implicit). */
-
-static void
-gfc_conv_variable (gfc_se * se, gfc_expr * expr)
-{
- gfc_ss *ss;
- gfc_ref *ref;
- gfc_symbol *sym;
- tree parent_decl = NULL_TREE;
- int parent_flag;
- bool return_value;
- bool alternate_entry;
- bool entry_master;
- bool is_classarray;
- bool first_time = true;
-
- sym = expr->symtree->n.sym;
- is_classarray = IS_CLASS_ARRAY (sym);
- ss = se->ss;
- if (ss != NULL)
- {
- gfc_ss_info *ss_info = ss->info;
-
- /* Check that something hasn't gone horribly wrong. */
- gcc_assert (ss != gfc_ss_terminator);
- gcc_assert (ss_info->expr == expr);
-
- /* A scalarized term. We already know the descriptor. */
- se->expr = ss_info->data.array.descriptor;
- se->string_length = ss_info->string_length;
- ref = ss_info->data.array.ref;
- if (ref)
- gcc_assert (ref->type == REF_ARRAY
- && ref->u.ar.type != AR_ELEMENT);
- else
- gfc_conv_tmp_array_ref (se);
- }
- else
- {
- tree se_expr = NULL_TREE;
-
- se->expr = gfc_get_symbol_decl (sym);
-
- /* Deal with references to a parent results or entries by storing
- the current_function_decl and moving to the parent_decl. */
- return_value = sym->attr.function && sym->result == sym;
- alternate_entry = sym->attr.function && sym->attr.entry
- && sym->result == sym;
- entry_master = sym->attr.result
- && sym->ns->proc_name->attr.entry_master
- && !gfc_return_by_reference (sym->ns->proc_name);
- if (current_function_decl)
- parent_decl = DECL_CONTEXT (current_function_decl);
-
- if ((se->expr == parent_decl && return_value)
- || (sym->ns && sym->ns->proc_name
- && parent_decl
- && sym->ns->proc_name->backend_decl == parent_decl
- && (alternate_entry || entry_master)))
- parent_flag = 1;
- else
- parent_flag = 0;
-
- /* Special case for assigning the return value of a function.
- Self recursive functions must have an explicit return value. */
- if (return_value && (se->expr == current_function_decl || parent_flag))
- se_expr = gfc_get_fake_result_decl (sym, parent_flag);
-
- /* Similarly for alternate entry points. */
- else if (alternate_entry
- && (sym->ns->proc_name->backend_decl == current_function_decl
- || parent_flag))
- {
- gfc_entry_list *el = NULL;
-
- for (el = sym->ns->entries; el; el = el->next)
- if (sym == el->sym)
- {
- se_expr = gfc_get_fake_result_decl (sym, parent_flag);
- break;
- }
- }
-
- else if (entry_master
- && (sym->ns->proc_name->backend_decl == current_function_decl
- || parent_flag))
- se_expr = gfc_get_fake_result_decl (sym, parent_flag);
-
- if (se_expr)
- se->expr = se_expr;
-
- /* Procedure actual arguments. Look out for temporary variables
- with the same attributes as function values. */
- else if (!sym->attr.temporary
- && sym->attr.flavor == FL_PROCEDURE
- && se->expr != current_function_decl)
- {
- if (!sym->attr.dummy && !sym->attr.proc_pointer)
- {
- gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
- se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
- }
- return;
- }
-
- /* Dereference the expression, where needed. */
- se->expr = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
- is_classarray);
-
- ref = expr->ref;
- }
-
- /* For character variables, also get the length. */
- if (sym->ts.type == BT_CHARACTER)
- {
- /* If the character length of an entry isn't set, get the length from
- the master function instead. */
- if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
- se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
- else
- se->string_length = sym->ts.u.cl->backend_decl;
- gcc_assert (se->string_length);
- }
-
- gfc_typespec *ts = &sym->ts;
- while (ref)
- {
- switch (ref->type)
- {
- case REF_ARRAY:
- /* Return the descriptor if that's what we want and this is an array
- section reference. */
- if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
- return;
-/* TODO: Pointers to single elements of array sections, eg elemental subs. */
- /* Return the descriptor for array pointers and allocations. */
- if (se->want_pointer
- && ref->next == NULL && (se->descriptor_only))
- return;
-
- gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
- /* Return a pointer to an element. */
- break;
-
- case REF_COMPONENT:
- ts = &ref->u.c.component->ts;
- if (first_time && is_classarray && sym->attr.dummy
- && se->descriptor_only
- && !CLASS_DATA (sym)->attr.allocatable
- && !CLASS_DATA (sym)->attr.class_pointer
- && CLASS_DATA (sym)->as
- && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
- && strcmp ("_data", ref->u.c.component->name) == 0)
- /* Skip the first ref of a _data component, because for class
- arrays that one is already done by introducing a temporary
- array descriptor. */
- break;
-
- if (ref->u.c.sym->attr.extension)
- conv_parent_component_references (se, ref);
-
- gfc_conv_component_ref (se, ref);
- if (!ref->next && ref->u.c.sym->attr.codimension
- && se->want_pointer && se->descriptor_only)
- return;
-
- break;
-
- case REF_SUBSTRING:
- gfc_conv_substring (se, ref, expr->ts.kind,
- expr->symtree->name, &expr->where);
- break;
-
- case REF_INQUIRY:
- conv_inquiry (se, ref, expr, ts);
- break;
-
- default:
- gcc_unreachable ();
- break;
- }
- first_time = false;
- ref = ref->next;
- }
- /* Pointer assignment, allocation or pass by reference. Arrays are handled
- separately. */
- if (se->want_pointer)
- {
- if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
- gfc_conv_string_parameter (se);
- else
- se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
- }
-}
-
-
-/* Unary ops are easy... Or they would be if ! was a valid op. */
-
-static void
-gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
-{
- gfc_se operand;
- tree type;
-
- gcc_assert (expr->ts.type != BT_CHARACTER);
- /* Initialize the operand. */
- gfc_init_se (&operand, se);
- gfc_conv_expr_val (&operand, expr->value.op.op1);
- gfc_add_block_to_block (&se->pre, &operand.pre);
-
- type = gfc_typenode_for_spec (&expr->ts);
-
- /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
- We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
- All other unary operators have an equivalent GIMPLE unary operator. */
- if (code == TRUTH_NOT_EXPR)
- se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
- build_int_cst (type, 0));
- else
- se->expr = fold_build1_loc (input_location, code, type, operand.expr);
-
-}
-
-/* Expand power operator to optimal multiplications when a value is raised
- to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
- Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
- Programming", 3rd Edition, 1998. */
-
-/* This code is mostly duplicated from expand_powi in the backend.
- We establish the "optimal power tree" lookup table with the defined size.
- The items in the table are the exponents used to calculate the index
- exponents. Any integer n less than the value can get an "addition chain",
- with the first node being one. */
-#define POWI_TABLE_SIZE 256
-
-/* The table is from builtins.c. */
-static const unsigned char powi_table[POWI_TABLE_SIZE] =
- {
- 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
- 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
- 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
- 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
- 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
- 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
- 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
- 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
- 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
- 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
- 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
- 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
- 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
- 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
- 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
- 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
- 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
- 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
- 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
- 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
- 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
- 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
- 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
- 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
- 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
- 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
- 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
- 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
- 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
- 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
- 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
- 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
- };
-
-/* If n is larger than lookup table's max index, we use the "window
- method". */
-#define POWI_WINDOW_SIZE 3
-
-/* Recursive function to expand the power operator. The temporary
- values are put in tmpvar. The function returns tmpvar[1] ** n. */
-static tree
-gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
-{
- tree op0;
- tree op1;
- tree tmp;
- int digit;
-
- if (n < POWI_TABLE_SIZE)
- {
- if (tmpvar[n])
- return tmpvar[n];
-
- op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
- op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
- }
- else if (n & 1)
- {
- digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
- op0 = gfc_conv_powi (se, n - digit, tmpvar);
- op1 = gfc_conv_powi (se, digit, tmpvar);
- }
- else
- {
- op0 = gfc_conv_powi (se, n >> 1, tmpvar);
- op1 = op0;
- }
-
- tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
- tmp = gfc_evaluate_now (tmp, &se->pre);
-
- if (n < POWI_TABLE_SIZE)
- tmpvar[n] = tmp;
-
- return tmp;
-}
-
-
-/* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
- return 1. Else return 0 and a call to runtime library functions
- will have to be built. */
-static int
-gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
-{
- tree cond;
- tree tmp;
- tree type;
- tree vartmp[POWI_TABLE_SIZE];
- HOST_WIDE_INT m;
- unsigned HOST_WIDE_INT n;
- int sgn;
- wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
-
- /* If exponent is too large, we won't expand it anyway, so don't bother
- with large integer values. */
- if (!wi::fits_shwi_p (wrhs))
- return 0;
-
- m = wrhs.to_shwi ();
- /* Use the wide_int's routine to reliably get the absolute value on all
- platforms. Then convert it to a HOST_WIDE_INT like above. */
- n = wi::abs (wrhs).to_shwi ();
-
- type = TREE_TYPE (lhs);
- sgn = tree_int_cst_sgn (rhs);
-
- if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
- || optimize_size) && (m > 2 || m < -1))
- return 0;
-
- /* rhs == 0 */
- if (sgn == 0)
- {
- se->expr = gfc_build_const (type, integer_one_node);
- return 1;
- }
-
- /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
- if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
- {
- tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
- lhs, build_int_cst (TREE_TYPE (lhs), -1));
- cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
- lhs, build_int_cst (TREE_TYPE (lhs), 1));
-
- /* If rhs is even,
- result = (lhs == 1 || lhs == -1) ? 1 : 0. */
- if ((n & 1) == 0)
- {
- tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- logical_type_node, tmp, cond);
- se->expr = fold_build3_loc (input_location, COND_EXPR, type,
- tmp, build_int_cst (type, 1),
- build_int_cst (type, 0));
- return 1;
- }
- /* If rhs is odd,
- result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
- tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
- build_int_cst (type, -1),
- build_int_cst (type, 0));
- se->expr = fold_build3_loc (input_location, COND_EXPR, type,
- cond, build_int_cst (type, 1), tmp);
- return 1;
- }
-
- memset (vartmp, 0, sizeof (vartmp));
- vartmp[1] = lhs;
- if (sgn == -1)
- {
- tmp = gfc_build_const (type, integer_one_node);
- vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
- vartmp[1]);
- }
-
- se->expr = gfc_conv_powi (se, n, vartmp);
-
- return 1;
-}
-
-
-/* Power op (**). Constant integer exponent has special handling. */
-
-static void
-gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
-{
- tree gfc_int4_type_node;
- int kind;
- int ikind;
- int res_ikind_1, res_ikind_2;
- gfc_se lse;
- gfc_se rse;
- tree fndecl = NULL;
-
- gfc_init_se (&lse, se);
- gfc_conv_expr_val (&lse, expr->value.op.op1);
- lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
- gfc_add_block_to_block (&se->pre, &lse.pre);
-
- gfc_init_se (&rse, se);
- gfc_conv_expr_val (&rse, expr->value.op.op2);
- gfc_add_block_to_block (&se->pre, &rse.pre);
-
- if (expr->value.op.op2->ts.type == BT_INTEGER
- && expr->value.op.op2->expr_type == EXPR_CONSTANT)
- if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
- return;
-
- if (INTEGER_CST_P (lse.expr)
- && TREE_CODE (TREE_TYPE (rse.expr)) == INTEGER_TYPE)
- {
- wi::tree_to_wide_ref wlhs = wi::to_wide (lse.expr);
- HOST_WIDE_INT v, w;
- int kind, ikind, bit_size;
-
- v = wlhs.to_shwi ();
- w = abs (v);
-
- kind = expr->value.op.op1->ts.kind;
- ikind = gfc_validate_kind (BT_INTEGER, kind, false);
- bit_size = gfc_integer_kinds[ikind].bit_size;
-
- if (v == 1)
- {
- /* 1**something is always 1. */
- se->expr = build_int_cst (TREE_TYPE (lse.expr), 1);
- return;
- }
- else if (v == -1)
- {
- /* (-1)**n is 1 - ((n & 1) << 1) */
- tree type;
- tree tmp;
-
- type = TREE_TYPE (lse.expr);
- tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
- rse.expr, build_int_cst (type, 1));
- tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
- tmp, build_int_cst (type, 1));
- tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
- build_int_cst (type, 1), tmp);
- se->expr = tmp;
- return;
- }
- else if (w > 0 && ((w & (w-1)) == 0) && ((w >> (bit_size-1)) == 0))
- {
- /* Here v is +/- 2**e. The further simplification uses
- 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
- 1<<(4*n), etc., but we have to make sure to return zero
- if the number of bits is too large. */
- tree lshift;
- tree type;
- tree shift;
- tree ge;
- tree cond;
- tree num_bits;
- tree cond2;
- tree tmp1;
-
- type = TREE_TYPE (lse.expr);
-
- if (w == 2)
- shift = rse.expr;
- else if (w == 4)
- shift = fold_build2_loc (input_location, PLUS_EXPR,
- TREE_TYPE (rse.expr),
- rse.expr, rse.expr);
- else
- {
- /* use popcount for fast log2(w) */
- int e = wi::popcount (w-1);
- shift = fold_build2_loc (input_location, MULT_EXPR,
- TREE_TYPE (rse.expr),
- build_int_cst (TREE_TYPE (rse.expr), e),
- rse.expr);
- }
-
- lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
- build_int_cst (type, 1), shift);
- ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
- rse.expr, build_int_cst (type, 0));
- cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift,
- build_int_cst (type, 0));
- num_bits = build_int_cst (TREE_TYPE (rse.expr), TYPE_PRECISION (type));
- cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
- rse.expr, num_bits);
- tmp1 = fold_build3_loc (input_location, COND_EXPR, type, cond2,
- build_int_cst (type, 0), cond);
- if (v > 0)
- {
- se->expr = tmp1;
- }
- else
- {
- /* for v < 0, calculate v**n = |v|**n * (-1)**n */
- tree tmp2;
- tmp2 = fold_build2_loc (input_location, BIT_AND_EXPR, type,
- rse.expr, build_int_cst (type, 1));
- tmp2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
- tmp2, build_int_cst (type, 1));
- tmp2 = fold_build2_loc (input_location, MINUS_EXPR, type,
- build_int_cst (type, 1), tmp2);
- se->expr = fold_build2_loc (input_location, MULT_EXPR, type,
- tmp1, tmp2);
- }
- return;
- }
- }
-
- gfc_int4_type_node = gfc_get_int_type (4);
-
- /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
- library routine. But in the end, we have to convert the result back
- if this case applies -- with res_ikind_K, we keep track whether operand K
- falls into this case. */
- res_ikind_1 = -1;
- res_ikind_2 = -1;
-
- kind = expr->value.op.op1->ts.kind;
- switch (expr->value.op.op2->ts.type)
- {
- case BT_INTEGER:
- ikind = expr->value.op.op2->ts.kind;
- switch (ikind)
- {
- case 1:
- case 2:
- rse.expr = convert (gfc_int4_type_node, rse.expr);
- res_ikind_2 = ikind;
- /* Fall through. */
-
- case 4:
- ikind = 0;
- break;
-
- case 8:
- ikind = 1;
- break;
-
- case 16:
- ikind = 2;
- break;
-
- default:
- gcc_unreachable ();
- }
- switch (kind)
- {
- case 1:
- case 2:
- if (expr->value.op.op1->ts.type == BT_INTEGER)
- {
- lse.expr = convert (gfc_int4_type_node, lse.expr);
- res_ikind_1 = kind;
- }
- else
- gcc_unreachable ();
- /* Fall through. */
-
- case 4:
- kind = 0;
- break;
-
- case 8:
- kind = 1;
- break;
-
- case 10:
- kind = 2;
- break;
-
- case 16:
- kind = 3;
- break;
-
- default:
- gcc_unreachable ();
- }
-
- switch (expr->value.op.op1->ts.type)
- {
- case BT_INTEGER:
- if (kind == 3) /* Case 16 was not handled properly above. */
- kind = 2;
- fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
- break;
-
- case BT_REAL:
- /* Use builtins for real ** int4. */
- if (ikind == 0)
- {
- switch (kind)
- {
- case 0:
- fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
- break;
-
- case 1:
- fndecl = builtin_decl_explicit (BUILT_IN_POWI);
- break;
-
- case 2:
- fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
- break;
-
- case 3:
- /* Use the __builtin_powil() only if real(kind=16) is
- actually the C long double type. */
- if (!gfc_real16_is_float128)
- fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
- break;
-
- default:
- gcc_unreachable ();
- }
- }
-
- /* If we don't have a good builtin for this, go for the
- library function. */
- if (!fndecl)
- fndecl = gfor_fndecl_math_powi[kind][ikind].real;
- break;
-
- case BT_COMPLEX:
- fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
- break;
-
- default:
- gcc_unreachable ();
- }
- break;
-
- case BT_REAL:
- fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
- break;
-
- case BT_COMPLEX:
- fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
- break;
-
- default:
- gcc_unreachable ();
- break;
- }
-
- se->expr = build_call_expr_loc (input_location,
- fndecl, 2, lse.expr, rse.expr);
-
- /* Convert the result back if it is of wrong integer kind. */
- if (res_ikind_1 != -1 && res_ikind_2 != -1)
- {
- /* We want the maximum of both operand kinds as result. */
- if (res_ikind_1 < res_ikind_2)
- res_ikind_1 = res_ikind_2;
- se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
- }
-}
-
-
-/* Generate code to allocate a string temporary. */
-
-tree
-gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
-{
- tree var;
- tree tmp;
-
- if (gfc_can_put_var_on_stack (len))
- {
- /* Create a temporary variable to hold the result. */
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- TREE_TYPE (len), len,
- build_int_cst (TREE_TYPE (len), 1));
- tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
-
- if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
- tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
- else
- tmp = build_array_type (TREE_TYPE (type), tmp);
-
- var = gfc_create_var (tmp, "str");
- var = gfc_build_addr_expr (type, var);
- }
- else
- {
- /* Allocate a temporary to hold the result. */
- var = gfc_create_var (type, "pstr");
- gcc_assert (POINTER_TYPE_P (type));
- tmp = TREE_TYPE (type);
- if (TREE_CODE (tmp) == ARRAY_TYPE)
- tmp = TREE_TYPE (tmp);
- tmp = TYPE_SIZE_UNIT (tmp);
- tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
- fold_convert (size_type_node, len),
- fold_convert (size_type_node, tmp));
- tmp = gfc_call_malloc (&se->pre, type, tmp);
- gfc_add_modify (&se->pre, var, tmp);
-
- /* Free the temporary afterwards. */
- tmp = gfc_call_free (var);
- gfc_add_expr_to_block (&se->post, tmp);
- }
-
- return var;
-}
-
-
-/* Handle a string concatenation operation. A temporary will be allocated to
- hold the result. */
-
-static void
-gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
-{
- gfc_se lse, rse;
- tree len, type, var, tmp, fndecl;
-
- gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
- && expr->value.op.op2->ts.type == BT_CHARACTER);
- gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
-
- gfc_init_se (&lse, se);
- gfc_conv_expr (&lse, expr->value.op.op1);
- gfc_conv_string_parameter (&lse);
- gfc_init_se (&rse, se);
- gfc_conv_expr (&rse, expr->value.op.op2);
- gfc_conv_string_parameter (&rse);
-
- gfc_add_block_to_block (&se->pre, &lse.pre);
- gfc_add_block_to_block (&se->pre, &rse.pre);
-
- type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
- len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
- if (len == NULL_TREE)
- {
- len = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_charlen_type_node,
- fold_convert (gfc_charlen_type_node,
- lse.string_length),
- fold_convert (gfc_charlen_type_node,
- rse.string_length));
- }
-
- type = build_pointer_type (type);
-
- var = gfc_conv_string_tmp (se, type, len);
-
- /* Do the actual concatenation. */
- if (expr->ts.kind == 1)
- fndecl = gfor_fndecl_concat_string;
- else if (expr->ts.kind == 4)
- fndecl = gfor_fndecl_concat_string_char4;
- else
- gcc_unreachable ();
-
- tmp = build_call_expr_loc (input_location,
- fndecl, 6, len, var, lse.string_length, lse.expr,
- rse.string_length, rse.expr);
- gfc_add_expr_to_block (&se->pre, tmp);
-
- /* Add the cleanup for the operands. */
- gfc_add_block_to_block (&se->pre, &rse.post);
- gfc_add_block_to_block (&se->pre, &lse.post);
-
- se->expr = var;
- se->string_length = len;
-}
-
-/* Translates an op expression. Common (binary) cases are handled by this
- function, others are passed on. Recursion is used in either case.
- We use the fact that (op1.ts == op2.ts) (except for the power
- operator **).
- Operators need no special handling for scalarized expressions as long as
- they call gfc_conv_simple_val to get their operands.
- Character strings get special handling. */
-
-static void
-gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
-{
- enum tree_code code;
- gfc_se lse;
- gfc_se rse;
- tree tmp, type;
- int lop;
- int checkstring;
-
- checkstring = 0;
- lop = 0;
- switch (expr->value.op.op)
- {
- case INTRINSIC_PARENTHESES:
- if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
- && flag_protect_parens)
- {
- gfc_conv_unary_op (PAREN_EXPR, se, expr);
- gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
- return;
- }
-
- /* Fallthrough. */
- case INTRINSIC_UPLUS:
- gfc_conv_expr (se, expr->value.op.op1);
- return;
-
- case INTRINSIC_UMINUS:
- gfc_conv_unary_op (NEGATE_EXPR, se, expr);
- return;
-
- case INTRINSIC_NOT:
- gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
- return;
-
- case INTRINSIC_PLUS:
- code = PLUS_EXPR;
- break;
-
- case INTRINSIC_MINUS:
- code = MINUS_EXPR;
- break;
-
- case INTRINSIC_TIMES:
- code = MULT_EXPR;
- break;
-
- case INTRINSIC_DIVIDE:
- /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
- an integer, we must round towards zero, so we use a
- TRUNC_DIV_EXPR. */
- if (expr->ts.type == BT_INTEGER)
- code = TRUNC_DIV_EXPR;
- else
- code = RDIV_EXPR;
- break;
-
- case INTRINSIC_POWER:
- gfc_conv_power_op (se, expr);
- return;
-
- case INTRINSIC_CONCAT:
- gfc_conv_concat_op (se, expr);
- return;
-
- case INTRINSIC_AND:
- code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
- lop = 1;
- break;
-
- case INTRINSIC_OR:
- code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
- lop = 1;
- break;
-
- /* EQV and NEQV only work on logicals, but since we represent them
- as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
- case INTRINSIC_EQ:
- case INTRINSIC_EQ_OS:
- case INTRINSIC_EQV:
- code = EQ_EXPR;
- checkstring = 1;
- lop = 1;
- break;
-
- case INTRINSIC_NE:
- case INTRINSIC_NE_OS:
- case INTRINSIC_NEQV:
- code = NE_EXPR;
- checkstring = 1;
- lop = 1;
- break;
-
- case INTRINSIC_GT:
- case INTRINSIC_GT_OS:
- code = GT_EXPR;
- checkstring = 1;
- lop = 1;
- break;
-
- case INTRINSIC_GE:
- case INTRINSIC_GE_OS:
- code = GE_EXPR;
- checkstring = 1;
- lop = 1;
- break;
-
- case INTRINSIC_LT:
- case INTRINSIC_LT_OS:
- code = LT_EXPR;
- checkstring = 1;
- lop = 1;
- break;
-
- case INTRINSIC_LE:
- case INTRINSIC_LE_OS:
- code = LE_EXPR;
- checkstring = 1;
- lop = 1;
- break;
-
- case INTRINSIC_USER:
- case INTRINSIC_ASSIGN:
- /* These should be converted into function calls by the frontend. */
- gcc_unreachable ();
-
- default:
- fatal_error (input_location, "Unknown intrinsic op");
- return;
- }
-
- /* The only exception to this is **, which is handled separately anyway. */
- gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
-
- if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
- checkstring = 0;
-
- /* lhs */
- gfc_init_se (&lse, se);
- gfc_conv_expr (&lse, expr->value.op.op1);
- gfc_add_block_to_block (&se->pre, &lse.pre);
-
- /* rhs */
- gfc_init_se (&rse, se);
- gfc_conv_expr (&rse, expr->value.op.op2);
- gfc_add_block_to_block (&se->pre, &rse.pre);
-
- if (checkstring)
- {
- gfc_conv_string_parameter (&lse);
- gfc_conv_string_parameter (&rse);
-
- lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
- rse.string_length, rse.expr,
- expr->value.op.op1->ts.kind,
- code);
- rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
- gfc_add_block_to_block (&lse.post, &rse.post);
- }
-
- type = gfc_typenode_for_spec (&expr->ts);
-
- if (lop)
- {
- /* The result of logical ops is always logical_type_node. */
- tmp = fold_build2_loc (input_location, code, logical_type_node,
- lse.expr, rse.expr);
- se->expr = convert (type, tmp);
- }
- else
- se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
-
- /* Add the post blocks. */
- gfc_add_block_to_block (&se->post, &rse.post);
- gfc_add_block_to_block (&se->post, &lse.post);
-}
-
-/* If a string's length is one, we convert it to a single character. */
-
-tree
-gfc_string_to_single_character (tree len, tree str, int kind)
-{
-
- if (len == NULL
- || !tree_fits_uhwi_p (len)
- || !POINTER_TYPE_P (TREE_TYPE (str)))
- return NULL_TREE;
-
- if (TREE_INT_CST_LOW (len) == 1)
- {
- str = fold_convert (gfc_get_pchar_type (kind), str);
- return build_fold_indirect_ref_loc (input_location, str);
- }
-
- if (kind == 1
- && TREE_CODE (str) == ADDR_EXPR
- && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
- && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
- && array_ref_low_bound (TREE_OPERAND (str, 0))
- == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
- && TREE_INT_CST_LOW (len) > 1
- && TREE_INT_CST_LOW (len)
- == (unsigned HOST_WIDE_INT)
- TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
- {
- tree ret = fold_convert (gfc_get_pchar_type (kind), str);
- ret = build_fold_indirect_ref_loc (input_location, ret);
- if (TREE_CODE (ret) == INTEGER_CST)
- {
- tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
- int i, length = TREE_STRING_LENGTH (string_cst);
- const char *ptr = TREE_STRING_POINTER (string_cst);
-
- for (i = 1; i < length; i++)
- if (ptr[i] != ' ')
- return NULL_TREE;
-
- return ret;
- }
- }
-
- return NULL_TREE;
-}
-
-
-static void
-conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
-{
- gcc_assert (expr);
-
- /* We used to modify the tree here. Now it is done earlier in
- the front-end, so we only check it here to avoid regressions. */
- if (sym->backend_decl)
- {
- gcc_assert (TREE_CODE (TREE_TYPE (sym->backend_decl)) == INTEGER_TYPE);
- gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym->backend_decl)) == 1);
- gcc_assert (TYPE_PRECISION (TREE_TYPE (sym->backend_decl)) == CHAR_TYPE_SIZE);
- gcc_assert (DECL_BY_REFERENCE (sym->backend_decl) == 0);
- }
-
- /* If we have a constant character expression, make it into an
- integer of type C char. */
- if ((*expr)->expr_type == EXPR_CONSTANT)
- {
- gfc_typespec ts;
- gfc_clear_ts (&ts);
-
- *expr = gfc_get_int_expr (gfc_default_character_kind, NULL,
- (*expr)->value.character.string[0]);
- }
- else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
- {
- if ((*expr)->ref == NULL)
- {
- se->expr = gfc_string_to_single_character
- (build_int_cst (integer_type_node, 1),
- gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
- gfc_get_symbol_decl
- ((*expr)->symtree->n.sym)),
- (*expr)->ts.kind);
- }
- else
- {
- gfc_conv_variable (se, *expr);
- se->expr = gfc_string_to_single_character
- (build_int_cst (integer_type_node, 1),
- gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
- se->expr),
- (*expr)->ts.kind);
- }
- }
-}
-
-/* Helper function for gfc_build_compare_string. Return LEN_TRIM value
- if STR is a string literal, otherwise return -1. */
-
-static int
-gfc_optimize_len_trim (tree len, tree str, int kind)
-{
- if (kind == 1
- && TREE_CODE (str) == ADDR_EXPR
- && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
- && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
- && array_ref_low_bound (TREE_OPERAND (str, 0))
- == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
- && tree_fits_uhwi_p (len)
- && tree_to_uhwi (len) >= 1
- && tree_to_uhwi (len)
- == (unsigned HOST_WIDE_INT)
- TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
- {
- tree folded = fold_convert (gfc_get_pchar_type (kind), str);
- folded = build_fold_indirect_ref_loc (input_location, folded);
- if (TREE_CODE (folded) == INTEGER_CST)
- {
- tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
- int length = TREE_STRING_LENGTH (string_cst);
- const char *ptr = TREE_STRING_POINTER (string_cst);
-
- for (; length > 0; length--)
- if (ptr[length - 1] != ' ')
- break;
-
- return length;
- }
- }
- return -1;
-}
-
-/* Helper to build a call to memcmp. */
-
-static tree
-build_memcmp_call (tree s1, tree s2, tree n)
-{
- tree tmp;
-
- if (!POINTER_TYPE_P (TREE_TYPE (s1)))
- s1 = gfc_build_addr_expr (pvoid_type_node, s1);
- else
- s1 = fold_convert (pvoid_type_node, s1);
-
- if (!POINTER_TYPE_P (TREE_TYPE (s2)))
- s2 = gfc_build_addr_expr (pvoid_type_node, s2);
- else
- s2 = fold_convert (pvoid_type_node, s2);
-
- n = fold_convert (size_type_node, n);
-
- tmp = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_MEMCMP),
- 3, s1, s2, n);
-
- return fold_convert (integer_type_node, tmp);
-}
-
-/* Compare two strings. If they are all single characters, the result is the
- subtraction of them. Otherwise, we build a library call. */
-
-tree
-gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
- enum tree_code code)
-{
- tree sc1;
- tree sc2;
- tree fndecl;
-
- gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
- gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
-
- sc1 = gfc_string_to_single_character (len1, str1, kind);
- sc2 = gfc_string_to_single_character (len2, str2, kind);
-
- if (sc1 != NULL_TREE && sc2 != NULL_TREE)
- {
- /* Deal with single character specially. */
- sc1 = fold_convert (integer_type_node, sc1);
- sc2 = fold_convert (integer_type_node, sc2);
- return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
- sc1, sc2);
- }
-
- if ((code == EQ_EXPR || code == NE_EXPR)
- && optimize
- && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
- {
- /* If one string is a string literal with LEN_TRIM longer
- than the length of the second string, the strings
- compare unequal. */
- int len = gfc_optimize_len_trim (len1, str1, kind);
- if (len > 0 && compare_tree_int (len2, len) < 0)
- return integer_one_node;
- len = gfc_optimize_len_trim (len2, str2, kind);
- if (len > 0 && compare_tree_int (len1, len) < 0)
- return integer_one_node;
- }
-
- /* We can compare via memcpy if the strings are known to be equal
- in length and they are
- - kind=1
- - kind=4 and the comparison is for (in)equality. */
-
- if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
- && tree_int_cst_equal (len1, len2)
- && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
- {
- tree tmp;
- tree chartype;
-
- chartype = gfc_get_char_type (kind);
- tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
- fold_convert (TREE_TYPE(len1),
- TYPE_SIZE_UNIT(chartype)),
- len1);
- return build_memcmp_call (str1, str2, tmp);
- }
-
- /* Build a call for the comparison. */
- if (kind == 1)
- fndecl = gfor_fndecl_compare_string;
- else if (kind == 4)
- fndecl = gfor_fndecl_compare_string_char4;
- else
- gcc_unreachable ();
-
- return build_call_expr_loc (input_location, fndecl, 4,
- len1, str1, len2, str2);
-}
-
-
-/* Return the backend_decl for a procedure pointer component. */
-
-static tree
-get_proc_ptr_comp (gfc_expr *e)
-{
- gfc_se comp_se;
- gfc_expr *e2;
- expr_t old_type;
-
- gfc_init_se (&comp_se, NULL);
- e2 = gfc_copy_expr (e);
- /* We have to restore the expr type later so that gfc_free_expr frees
- the exact same thing that was allocated.
- TODO: This is ugly. */
- old_type = e2->expr_type;
- e2->expr_type = EXPR_VARIABLE;
- gfc_conv_expr (&comp_se, e2);
- e2->expr_type = old_type;
- gfc_free_expr (e2);
- return build_fold_addr_expr_loc (input_location, comp_se.expr);
-}
-
-
-/* Convert a typebound function reference from a class object. */
-static void
-conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
-{
- gfc_ref *ref;
- tree var;
-
- if (!VAR_P (base_object))
- {
- var = gfc_create_var (TREE_TYPE (base_object), NULL);
- gfc_add_modify (&se->pre, var, base_object);
- }
- se->expr = gfc_class_vptr_get (base_object);
- se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
- ref = expr->ref;
- while (ref && ref->next)
- ref = ref->next;
- gcc_assert (ref && ref->type == REF_COMPONENT);
- if (ref->u.c.sym->attr.extension)
- conv_parent_component_references (se, ref);
- gfc_conv_component_ref (se, ref);
- se->expr = build_fold_addr_expr_loc (input_location, se->expr);
-}
-
-
-static void
-conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr,
- gfc_actual_arglist *actual_args)
-{
- tree tmp;
-
- if (gfc_is_proc_ptr_comp (expr))
- tmp = get_proc_ptr_comp (expr);
- else if (sym->attr.dummy)
- {
- tmp = gfc_get_symbol_decl (sym);
- if (sym->attr.proc_pointer)
- tmp = build_fold_indirect_ref_loc (input_location,
- tmp);
- gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
- && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
- }
- else
- {
- if (!sym->backend_decl)
- sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
-
- TREE_USED (sym->backend_decl) = 1;
-
- tmp = sym->backend_decl;
-
- if (sym->attr.cray_pointee)
- {
- /* TODO - make the cray pointee a pointer to a procedure,
- assign the pointer to it and use it for the call. This
- will do for now! */
- tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
- gfc_get_symbol_decl (sym->cp_pointer));
- tmp = gfc_evaluate_now (tmp, &se->pre);
- }
-
- if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
- {
- gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
- }
- }
- se->expr = tmp;
-}
-
-
-/* Initialize MAPPING. */
-
-void
-gfc_init_interface_mapping (gfc_interface_mapping * mapping)
-{
- mapping->syms = NULL;
- mapping->charlens = NULL;
-}
-
-
-/* Free all memory held by MAPPING (but not MAPPING itself). */
-
-void
-gfc_free_interface_mapping (gfc_interface_mapping * mapping)
-{
- gfc_interface_sym_mapping *sym;
- gfc_interface_sym_mapping *nextsym;
- gfc_charlen *cl;
- gfc_charlen *nextcl;
-
- for (sym = mapping->syms; sym; sym = nextsym)
- {
- nextsym = sym->next;
- sym->new_sym->n.sym->formal = NULL;
- gfc_free_symbol (sym->new_sym->n.sym);
- gfc_free_expr (sym->expr);
- free (sym->new_sym);
- free (sym);
- }
- for (cl = mapping->charlens; cl; cl = nextcl)
- {
- nextcl = cl->next;
- gfc_free_expr (cl->length);
- free (cl);
- }
-}
-
-
-/* Return a copy of gfc_charlen CL. Add the returned structure to
- MAPPING so that it will be freed by gfc_free_interface_mapping. */
-
-static gfc_charlen *
-gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
- gfc_charlen * cl)
-{
- gfc_charlen *new_charlen;
-
- new_charlen = gfc_get_charlen ();
- new_charlen->next = mapping->charlens;
- new_charlen->length = gfc_copy_expr (cl->length);
-
- mapping->charlens = new_charlen;
- return new_charlen;
-}
-
-
-/* A subroutine of gfc_add_interface_mapping. Return a descriptorless
- array variable that can be used as the actual argument for dummy
- argument SYM. Add any initialization code to BLOCK. PACKED is as
- for gfc_get_nodesc_array_type and DATA points to the first element
- in the passed array. */
-
-static tree
-gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
- gfc_packed packed, tree data)
-{
- tree type;
- tree var;
-
- type = gfc_typenode_for_spec (&sym->ts);
- type = gfc_get_nodesc_array_type (type, sym->as, packed,
- !sym->attr.target && !sym->attr.pointer
- && !sym->attr.proc_pointer);
-
- var = gfc_create_var (type, "ifm");
- gfc_add_modify (block, var, fold_convert (type, data));
-
- return var;
-}
-
-
-/* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
- and offset of descriptorless array type TYPE given that it has the same
- size as DESC. Add any set-up code to BLOCK. */
-
-static void
-gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
-{
- int n;
- tree dim;
- tree offset;
- tree tmp;
-
- offset = gfc_index_zero_node;
- for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
- {
- dim = gfc_rank_cst[n];
- GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
- if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
- {
- GFC_TYPE_ARRAY_LBOUND (type, n)
- = gfc_conv_descriptor_lbound_get (desc, dim);
- GFC_TYPE_ARRAY_UBOUND (type, n)
- = gfc_conv_descriptor_ubound_get (desc, dim);
- }
- else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
- {
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- gfc_conv_descriptor_ubound_get (desc, dim),
- gfc_conv_descriptor_lbound_get (desc, dim));
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type,
- GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
- tmp = gfc_evaluate_now (tmp, block);
- GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
- }
- tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- GFC_TYPE_ARRAY_LBOUND (type, n),
- GFC_TYPE_ARRAY_STRIDE (type, n));
- offset = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, offset, tmp);
- }
- offset = gfc_evaluate_now (offset, block);
- GFC_TYPE_ARRAY_OFFSET (type) = offset;
-}
-
-
-/* Extend MAPPING so that it maps dummy argument SYM to the value stored
- in SE. The caller may still use se->expr and se->string_length after
- calling this function. */
-
-void
-gfc_add_interface_mapping (gfc_interface_mapping * mapping,
- gfc_symbol * sym, gfc_se * se,
- gfc_expr *expr)
-{
- gfc_interface_sym_mapping *sm;
- tree desc;
- tree tmp;
- tree value;
- gfc_symbol *new_sym;
- gfc_symtree *root;
- gfc_symtree *new_symtree;
-
- /* Create a new symbol to represent the actual argument. */
- new_sym = gfc_new_symbol (sym->name, NULL);
- new_sym->ts = sym->ts;
- new_sym->as = gfc_copy_array_spec (sym->as);
- new_sym->attr.referenced = 1;
- new_sym->attr.dimension = sym->attr.dimension;
- new_sym->attr.contiguous = sym->attr.contiguous;
- new_sym->attr.codimension = sym->attr.codimension;
- new_sym->attr.pointer = sym->attr.pointer;
- new_sym->attr.allocatable = sym->attr.allocatable;
- new_sym->attr.flavor = sym->attr.flavor;
- new_sym->attr.function = sym->attr.function;
-
- /* Ensure that the interface is available and that
- descriptors are passed for array actual arguments. */
- if (sym->attr.flavor == FL_PROCEDURE)
- {
- new_sym->formal = expr->symtree->n.sym->formal;
- new_sym->attr.always_explicit
- = expr->symtree->n.sym->attr.always_explicit;
- }
-
- /* Create a fake symtree for it. */
- root = NULL;
- new_symtree = gfc_new_symtree (&root, sym->name);
- new_symtree->n.sym = new_sym;
- gcc_assert (new_symtree == root);
-
- /* Create a dummy->actual mapping. */
- sm = XCNEW (gfc_interface_sym_mapping);
- sm->next = mapping->syms;
- sm->old = sym;
- sm->new_sym = new_symtree;
- sm->expr = gfc_copy_expr (expr);
- mapping->syms = sm;
-
- /* Stabilize the argument's value. */
- if (!sym->attr.function && se)
- se->expr = gfc_evaluate_now (se->expr, &se->pre);
-
- if (sym->ts.type == BT_CHARACTER)
- {
- /* Create a copy of the dummy argument's length. */
- new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
- sm->expr->ts.u.cl = new_sym->ts.u.cl;
-
- /* If the length is specified as "*", record the length that
- the caller is passing. We should use the callee's length
- in all other cases. */
- if (!new_sym->ts.u.cl->length && se)
- {
- se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
- new_sym->ts.u.cl->backend_decl = se->string_length;
- }
- }
-
- if (!se)
- return;
-
- /* Use the passed value as-is if the argument is a function. */
- if (sym->attr.flavor == FL_PROCEDURE)
- value = se->expr;
-
- /* If the argument is a pass-by-value scalar, use the value as is. */
- else if (!sym->attr.dimension && sym->attr.value)
- value = se->expr;
-
- /* If the argument is either a string or a pointer to a string,
- convert it to a boundless character type. */
- else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
- {
- tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
- tmp = build_pointer_type (tmp);
- if (sym->attr.pointer)
- value = build_fold_indirect_ref_loc (input_location,
- se->expr);
- else
- value = se->expr;
- value = fold_convert (tmp, value);
- }
-
- /* If the argument is a scalar, a pointer to an array or an allocatable,
- dereference it. */
- else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
- value = build_fold_indirect_ref_loc (input_location,
- se->expr);
-
- /* For character(*), use the actual argument's descriptor. */
- else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
- value = build_fold_indirect_ref_loc (input_location,
- se->expr);
-
- /* If the argument is an array descriptor, use it to determine
- information about the actual argument's shape. */
- else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
- && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
- {
- /* Get the actual argument's descriptor. */
- desc = build_fold_indirect_ref_loc (input_location,
- se->expr);
-
- /* Create the replacement variable. */
- tmp = gfc_conv_descriptor_data_get (desc);
- value = gfc_get_interface_mapping_array (&se->pre, sym,
- PACKED_NO, tmp);
-
- /* Use DESC to work out the upper bounds, strides and offset. */
- gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
- }
- else
- /* Otherwise we have a packed array. */
- value = gfc_get_interface_mapping_array (&se->pre, sym,
- PACKED_FULL, se->expr);
-
- new_sym->backend_decl = value;
-}
-
-
-/* Called once all dummy argument mappings have been added to MAPPING,
- but before the mapping is used to evaluate expressions. Pre-evaluate
- the length of each argument, adding any initialization code to PRE and
- any finalization code to POST. */
-
-static void
-gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
- stmtblock_t * pre, stmtblock_t * post)
-{
- gfc_interface_sym_mapping *sym;
- gfc_expr *expr;
- gfc_se se;
-
- for (sym = mapping->syms; sym; sym = sym->next)
- if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
- && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
- {
- expr = sym->new_sym->n.sym->ts.u.cl->length;
- gfc_apply_interface_mapping_to_expr (mapping, expr);
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, expr);
- se.expr = fold_convert (gfc_charlen_type_node, se.expr);
- se.expr = gfc_evaluate_now (se.expr, &se.pre);
- gfc_add_block_to_block (pre, &se.pre);
- gfc_add_block_to_block (post, &se.post);
-
- sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
- }
-}
-
-
-/* Like gfc_apply_interface_mapping_to_expr, but applied to
- constructor C. */
-
-static void
-gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
- gfc_constructor_base base)
-{
- gfc_constructor *c;
- for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
- {
- gfc_apply_interface_mapping_to_expr (mapping, c->expr);
- if (c->iterator)
- {
- gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
- gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
- gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
- }
- }
-}
-
-
-/* Like gfc_apply_interface_mapping_to_expr, but applied to
- reference REF. */
-
-static void
-gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
- gfc_ref * ref)
-{
- int n;
-
- for (; ref; ref = ref->next)
- switch (ref->type)
- {
- case REF_ARRAY:
- for (n = 0; n < ref->u.ar.dimen; n++)
- {
- gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
- gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
- gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
- }
- break;
-
- case REF_COMPONENT:
- case REF_INQUIRY:
- break;
-
- case REF_SUBSTRING:
- gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
- gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
- break;
- }
-}
-
-
-/* Convert intrinsic function calls into result expressions. */
-
-static bool
-gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
-{
- gfc_symbol *sym;
- gfc_expr *new_expr;
- gfc_expr *arg1;
- gfc_expr *arg2;
- int d, dup;
-
- arg1 = expr->value.function.actual->expr;
- if (expr->value.function.actual->next)
- arg2 = expr->value.function.actual->next->expr;
- else
- arg2 = NULL;
-
- sym = arg1->symtree->n.sym;
-
- if (sym->attr.dummy)
- return false;
-
- new_expr = NULL;
-
- switch (expr->value.function.isym->id)
- {
- case GFC_ISYM_LEN:
- /* TODO figure out why this condition is necessary. */
- if (sym->attr.function
- && (arg1->ts.u.cl->length == NULL
- || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
- && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
- return false;
-
- new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
- break;
-
- case GFC_ISYM_LEN_TRIM:
- new_expr = gfc_copy_expr (arg1);
- gfc_apply_interface_mapping_to_expr (mapping, new_expr);
-
- if (!new_expr)
- return false;
-
- gfc_replace_expr (arg1, new_expr);
- return true;
-
- case GFC_ISYM_SIZE:
- if (!sym->as || sym->as->rank == 0)
- return false;
-
- if (arg2 && arg2->expr_type == EXPR_CONSTANT)
- {
- dup = mpz_get_si (arg2->value.integer);
- d = dup - 1;
- }
- else
- {
- dup = sym->as->rank;
- d = 0;
- }
-
- for (; d < dup; d++)
- {
- gfc_expr *tmp;
-
- if (!sym->as->upper[d] || !sym->as->lower[d])
- {
- gfc_free_expr (new_expr);
- return false;
- }
-
- tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
- gfc_get_int_expr (gfc_default_integer_kind,
- NULL, 1));
- tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
- if (new_expr)
- new_expr = gfc_multiply (new_expr, tmp);
- else
- new_expr = tmp;
- }
- break;
-
- case GFC_ISYM_LBOUND:
- case GFC_ISYM_UBOUND:
- /* TODO These implementations of lbound and ubound do not limit if
- the size < 0, according to F95's 13.14.53 and 13.14.113. */
-
- if (!sym->as || sym->as->rank == 0)
- return false;
-
- if (arg2 && arg2->expr_type == EXPR_CONSTANT)
- d = mpz_get_si (arg2->value.integer) - 1;
- else
- return false;
-
- if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
- {
- if (sym->as->lower[d])
- new_expr = gfc_copy_expr (sym->as->lower[d]);
- }
- else
- {
- if (sym->as->upper[d])
- new_expr = gfc_copy_expr (sym->as->upper[d]);
- }
- break;
-
- default:
- break;
- }
-
- gfc_apply_interface_mapping_to_expr (mapping, new_expr);
- if (!new_expr)
- return false;
-
- gfc_replace_expr (expr, new_expr);
- return true;
-}
-
-
-static void
-gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
- gfc_interface_mapping * mapping)
-{
- gfc_formal_arglist *f;
- gfc_actual_arglist *actual;
-
- actual = expr->value.function.actual;
- f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
-
- for (; f && actual; f = f->next, actual = actual->next)
- {
- if (!actual->expr)
- continue;
-
- gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
- }
-
- if (map_expr->symtree->n.sym->attr.dimension)
- {
- int d;
- gfc_array_spec *as;
-
- as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
-
- for (d = 0; d < as->rank; d++)
- {
- gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
- gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
- }
-
- expr->value.function.esym->as = as;
- }
-
- if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
- {
- expr->value.function.esym->ts.u.cl->length
- = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
-
- gfc_apply_interface_mapping_to_expr (mapping,
- expr->value.function.esym->ts.u.cl->length);
- }
-}
-
-
-/* EXPR is a copy of an expression that appeared in the interface
- associated with MAPPING. Walk it recursively looking for references to
- dummy arguments that MAPPING maps to actual arguments. Replace each such
- reference with a reference to the associated actual argument. */
-
-static void
-gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
- gfc_expr * expr)
-{
- gfc_interface_sym_mapping *sym;
- gfc_actual_arglist *actual;
-
- if (!expr)
- return;
-
- /* Copying an expression does not copy its length, so do that here. */
- if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
- {
- expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
- gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
- }
-
- /* Apply the mapping to any references. */
- gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
-
- /* ...and to the expression's symbol, if it has one. */
- /* TODO Find out why the condition on expr->symtree had to be moved into
- the loop rather than being outside it, as originally. */
- for (sym = mapping->syms; sym; sym = sym->next)
- if (expr->symtree && sym->old == expr->symtree->n.sym)
- {
- if (sym->new_sym->n.sym->backend_decl)
- expr->symtree = sym->new_sym;
- else if (sym->expr)
- gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
- }
-
- /* ...and to subexpressions in expr->value. */
- switch (expr->expr_type)
- {
- case EXPR_VARIABLE:
- case EXPR_CONSTANT:
- case EXPR_NULL:
- case EXPR_SUBSTRING:
- break;
-
- case EXPR_OP:
- gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
- gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
- break;
-
- case EXPR_FUNCTION:
- for (actual = expr->value.function.actual; actual; actual = actual->next)
- gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
-
- if (expr->value.function.esym == NULL
- && expr->value.function.isym != NULL
- && expr->value.function.actual
- && expr->value.function.actual->expr
- && expr->value.function.actual->expr->symtree
- && gfc_map_intrinsic_function (expr, mapping))
- break;
-
- for (sym = mapping->syms; sym; sym = sym->next)
- if (sym->old == expr->value.function.esym)
- {
- expr->value.function.esym = sym->new_sym->n.sym;
- gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
- expr->value.function.esym->result = sym->new_sym->n.sym;
- }
- break;
-
- case EXPR_ARRAY:
- case EXPR_STRUCTURE:
- gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
- break;
-
- case EXPR_COMPCALL:
- case EXPR_PPC:
- case EXPR_UNKNOWN:
- gcc_unreachable ();
- break;
- }
-
- return;
-}
-
-
-/* Evaluate interface expression EXPR using MAPPING. Store the result
- in SE. */
-
-void
-gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
- gfc_se * se, gfc_expr * expr)
-{
- expr = gfc_copy_expr (expr);
- gfc_apply_interface_mapping_to_expr (mapping, expr);
- gfc_conv_expr (se, expr);
- se->expr = gfc_evaluate_now (se->expr, &se->pre);
- gfc_free_expr (expr);
-}
-
-
-/* Returns a reference to a temporary array into which a component of
- an actual argument derived type array is copied and then returned
- after the function call. */
-void
-gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
- sym_intent intent, bool formal_ptr,
- const gfc_symbol *fsym, const char *proc_name,
- gfc_symbol *sym, bool check_contiguous)
-{
- gfc_se lse;
- gfc_se rse;
- gfc_ss *lss;
- gfc_ss *rss;
- gfc_loopinfo loop;
- gfc_loopinfo loop2;
- gfc_array_info *info;
- tree offset;
- tree tmp_index;
- tree tmp;
- tree base_type;
- tree size;
- stmtblock_t body;
- int n;
- int dimen;
- gfc_se work_se;
- gfc_se *parmse;
- bool pass_optional;
-
- pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
-
- if (pass_optional || check_contiguous)
- {
- gfc_init_se (&work_se, NULL);
- parmse = &work_se;
- }
- else
- parmse = se;
-
- if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
- {
- /* We will create a temporary array, so let us warn. */
- char * msg;
-
- if (fsym && proc_name)
- msg = xasprintf ("An array temporary was created for argument "
- "'%s' of procedure '%s'", fsym->name, proc_name);
- else
- msg = xasprintf ("An array temporary was created");
-
- tmp = build_int_cst (logical_type_node, 1);
- gfc_trans_runtime_check (false, true, tmp, &parmse->pre,
- &expr->where, msg);
- free (msg);
- }
-
- gfc_init_se (&lse, NULL);
- gfc_init_se (&rse, NULL);
-
- /* Walk the argument expression. */
- rss = gfc_walk_expr (expr);
-
- gcc_assert (rss != gfc_ss_terminator);
-
- /* Initialize the scalarizer. */
- gfc_init_loopinfo (&loop);
- gfc_add_ss_to_loop (&loop, rss);
-
- /* Calculate the bounds of the scalarization. */
- gfc_conv_ss_startstride (&loop);
-
- /* Build an ss for the temporary. */
- if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
- gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
-
- base_type = gfc_typenode_for_spec (&expr->ts);
- if (GFC_ARRAY_TYPE_P (base_type)
- || GFC_DESCRIPTOR_TYPE_P (base_type))
- base_type = gfc_get_element_type (base_type);
-
- if (expr->ts.type == BT_CLASS)
- base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
-
- loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
- ? expr->ts.u.cl->backend_decl
- : NULL),
- loop.dimen);
-
- parmse->string_length = loop.temp_ss->info->string_length;
-
- /* Associate the SS with the loop. */
- gfc_add_ss_to_loop (&loop, loop.temp_ss);
-
- /* Setup the scalarizing loops. */
- gfc_conv_loop_setup (&loop, &expr->where);
-
- /* Pass the temporary descriptor back to the caller. */
- info = &loop.temp_ss->info->data.array;
- parmse->expr = info->descriptor;
-
- /* Setup the gfc_se structures. */
- gfc_copy_loopinfo_to_se (&lse, &loop);
- gfc_copy_loopinfo_to_se (&rse, &loop);
-
- rse.ss = rss;
- lse.ss = loop.temp_ss;
- gfc_mark_ss_chain_used (rss, 1);
- gfc_mark_ss_chain_used (loop.temp_ss, 1);
-
- /* Start the scalarized loop body. */
- gfc_start_scalarized_body (&loop, &body);
-
- /* Translate the expression. */
- gfc_conv_expr (&rse, expr);
-
- /* Reset the offset for the function call since the loop
- is zero based on the data pointer. Note that the temp
- comes first in the loop chain since it is added second. */
- if (gfc_is_class_array_function (expr))
- {
- tmp = loop.ss->loop_chain->info->data.array.descriptor;
- gfc_conv_descriptor_offset_set (&loop.pre, tmp,
- gfc_index_zero_node);
- }
-
- gfc_conv_tmp_array_ref (&lse);
-
- if (intent != INTENT_OUT)
- {
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
- gfc_add_expr_to_block (&body, tmp);
- gcc_assert (rse.ss == gfc_ss_terminator);
- gfc_trans_scalarizing_loops (&loop, &body);
- }
- else
- {
- /* Make sure that the temporary declaration survives by merging
- all the loop declarations into the current context. */
- for (n = 0; n < loop.dimen; n++)
- {
- gfc_merge_block_scope (&body);
- body = loop.code[loop.order[n]];
- }
- gfc_merge_block_scope (&body);
- }
-
- /* Add the post block after the second loop, so that any
- freeing of allocated memory is done at the right time. */
- gfc_add_block_to_block (&parmse->pre, &loop.pre);
-
- /**********Copy the temporary back again.*********/
-
- gfc_init_se (&lse, NULL);
- gfc_init_se (&rse, NULL);
-
- /* Walk the argument expression. */
- lss = gfc_walk_expr (expr);
- rse.ss = loop.temp_ss;
- lse.ss = lss;
-
- /* Initialize the scalarizer. */
- gfc_init_loopinfo (&loop2);
- gfc_add_ss_to_loop (&loop2, lss);
-
- dimen = rse.ss->dimen;
-
- /* Skip the write-out loop for this case. */
- if (gfc_is_class_array_function (expr))
- goto class_array_fcn;
-
- /* Calculate the bounds of the scalarization. */
- gfc_conv_ss_startstride (&loop2);
-
- /* Setup the scalarizing loops. */
- gfc_conv_loop_setup (&loop2, &expr->where);
-
- gfc_copy_loopinfo_to_se (&lse, &loop2);
- gfc_copy_loopinfo_to_se (&rse, &loop2);
-
- gfc_mark_ss_chain_used (lss, 1);
- gfc_mark_ss_chain_used (loop.temp_ss, 1);
-
- /* Declare the variable to hold the temporary offset and start the
- scalarized loop body. */
- offset = gfc_create_var (gfc_array_index_type, NULL);
- gfc_start_scalarized_body (&loop2, &body);
-
- /* Build the offsets for the temporary from the loop variables. The
- temporary array has lbounds of zero and strides of one in all
- dimensions, so this is very simple. The offset is only computed
- outside the innermost loop, so the overall transfer could be
- optimized further. */
- info = &rse.ss->info->data.array;
-
- tmp_index = gfc_index_zero_node;
- for (n = dimen - 1; n > 0; n--)
- {
- tree tmp_str;
- tmp = rse.loop->loopvar[n];
- tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- tmp, rse.loop->from[n]);
- tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- tmp, tmp_index);
-
- tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- rse.loop->to[n-1], rse.loop->from[n-1]);
- tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type,
- tmp_str, gfc_index_one_node);
-
- tmp_index = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, tmp, tmp_str);
- }
-
- tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- tmp_index, rse.loop->from[0]);
- gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
-
- tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type,
- rse.loop->loopvar[0], offset);
-
- /* Now use the offset for the reference. */
- tmp = build_fold_indirect_ref_loc (input_location,
- info->data);
- rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
-
- if (expr->ts.type == BT_CHARACTER)
- rse.string_length = expr->ts.u.cl->backend_decl;
-
- gfc_conv_expr (&lse, expr);
-
- gcc_assert (lse.ss == gfc_ss_terminator);
-
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true);
- gfc_add_expr_to_block (&body, tmp);
-
- /* Generate the copying loops. */
- gfc_trans_scalarizing_loops (&loop2, &body);
-
- /* Wrap the whole thing up by adding the second loop to the post-block
- and following it by the post-block of the first loop. In this way,
- if the temporary needs freeing, it is done after use! */
- if (intent != INTENT_IN)
- {
- gfc_add_block_to_block (&parmse->post, &loop2.pre);
- gfc_add_block_to_block (&parmse->post, &loop2.post);
- }
-
-class_array_fcn:
-
- gfc_add_block_to_block (&parmse->post, &loop.post);
-
- gfc_cleanup_loop (&loop);
- gfc_cleanup_loop (&loop2);
-
- /* Pass the string length to the argument expression. */
- if (expr->ts.type == BT_CHARACTER)
- parmse->string_length = expr->ts.u.cl->backend_decl;
-
- /* Determine the offset for pointer formal arguments and set the
- lbounds to one. */
- if (formal_ptr)
- {
- size = gfc_index_one_node;
- offset = gfc_index_zero_node;
- for (n = 0; n < dimen; n++)
- {
- tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
- gfc_rank_cst[n]);
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, tmp,
- gfc_index_one_node);
- gfc_conv_descriptor_ubound_set (&parmse->pre,
- parmse->expr,
- gfc_rank_cst[n],
- tmp);
- gfc_conv_descriptor_lbound_set (&parmse->pre,
- parmse->expr,
- gfc_rank_cst[n],
- gfc_index_one_node);
- size = gfc_evaluate_now (size, &parmse->pre);
- offset = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- offset, size);
- offset = gfc_evaluate_now (offset, &parmse->pre);
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- rse.loop->to[n], rse.loop->from[n]);
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type,
- tmp, gfc_index_one_node);
- size = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, size, tmp);
- }
-
- gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
- offset);
- }
-
- /* We want either the address for the data or the address of the descriptor,
- depending on the mode of passing array arguments. */
- if (g77)
- parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
- else
- parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
-
- /* Basically make this into
-
- if (present)
- {
- if (contiguous)
- {
- pointer = a;
- }
- else
- {
- parmse->pre();
- pointer = parmse->expr;
- }
- }
- else
- pointer = NULL;
-
- foo (pointer);
- if (present && !contiguous)
- se->post();
-
- */
-
- if (pass_optional || check_contiguous)
- {
- tree type;
- stmtblock_t else_block;
- tree pre_stmts, post_stmts;
- tree pointer;
- tree else_stmt;
- tree present_var = NULL_TREE;
- tree cont_var = NULL_TREE;
- tree post_cond;
-
- type = TREE_TYPE (parmse->expr);
- if (POINTER_TYPE_P (type) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
- type = TREE_TYPE (type);
- pointer = gfc_create_var (type, "arg_ptr");
-
- if (check_contiguous)
- {
- gfc_se cont_se, array_se;
- stmtblock_t if_block, else_block;
- tree if_stmt, else_stmt;
- mpz_t size;
- bool size_set;
-
- cont_var = gfc_create_var (boolean_type_node, "contiguous");
-
- /* If the size is known to be one at compile-time, set
- cont_var to true unconditionally. This may look
- inelegant, but we're only doing this during
- optimization, so the statements will be optimized away,
- and this saves complexity here. */
-
- size_set = gfc_array_size (expr, &size);
- if (size_set && mpz_cmp_ui (size, 1) == 0)
- {
- gfc_add_modify (&se->pre, cont_var,
- build_one_cst (boolean_type_node));
- }
- else
- {
- /* cont_var = is_contiguous (expr); . */
- gfc_init_se (&cont_se, parmse);
- gfc_conv_is_contiguous_expr (&cont_se, expr);
- gfc_add_block_to_block (&se->pre, &(&cont_se)->pre);
- gfc_add_modify (&se->pre, cont_var, cont_se.expr);
- gfc_add_block_to_block (&se->pre, &(&cont_se)->post);
- }
-
- if (size_set)
- mpz_clear (size);
-
- /* arrayse->expr = descriptor of a. */
- gfc_init_se (&array_se, se);
- gfc_conv_expr_descriptor (&array_se, expr);
- gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
- gfc_add_block_to_block (&se->pre, &(&array_se)->post);
-
- /* if_stmt = { descriptor ? pointer = a : pointer = &a[0]; } . */
- gfc_init_block (&if_block);
- if (GFC_DESCRIPTOR_TYPE_P (type))
- gfc_add_modify (&if_block, pointer, array_se.expr);
- else
- {
- tmp = gfc_conv_array_data (array_se.expr);
- tmp = fold_convert (type, tmp);
- gfc_add_modify (&if_block, pointer, tmp);
- }
- if_stmt = gfc_finish_block (&if_block);
-
- /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
- gfc_init_block (&else_block);
- gfc_add_block_to_block (&else_block, &parmse->pre);
- tmp = (GFC_DESCRIPTOR_TYPE_P (type)
- ? build_fold_indirect_ref_loc (input_location, parmse->expr)
- : parmse->expr);
- gfc_add_modify (&else_block, pointer, tmp);
- else_stmt = gfc_finish_block (&else_block);
-
- /* And put the above into an if statement. */
- pre_stmts = fold_build3_loc (input_location, COND_EXPR, void_type_node,
- gfc_likely (cont_var,
- PRED_FORTRAN_CONTIGUOUS),
- if_stmt, else_stmt);
- }
- else
- {
- /* pointer = pramse->expr; . */
- gfc_add_modify (&parmse->pre, pointer, parmse->expr);
- pre_stmts = gfc_finish_block (&parmse->pre);
- }
-
- if (pass_optional)
- {
- present_var = gfc_create_var (boolean_type_node, "present");
-
- /* present_var = present(sym); . */
- tmp = gfc_conv_expr_present (sym);
- tmp = fold_convert (boolean_type_node, tmp);
- gfc_add_modify (&se->pre, present_var, tmp);
-
- /* else_stmt = { pointer = NULL; } . */
- gfc_init_block (&else_block);
- if (GFC_DESCRIPTOR_TYPE_P (type))
- gfc_conv_descriptor_data_set (&else_block, pointer,
- null_pointer_node);
- else
- gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
- else_stmt = gfc_finish_block (&else_block);
-
- tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
- gfc_likely (present_var,
- PRED_FORTRAN_ABSENT_DUMMY),
- pre_stmts, else_stmt);
- gfc_add_expr_to_block (&se->pre, tmp);
- }
- else
- gfc_add_expr_to_block (&se->pre, pre_stmts);
-
- post_stmts = gfc_finish_block (&parmse->post);
-
- /* Put together the post stuff, plus the optional
- deallocation. */
- if (check_contiguous)
- {
- /* !cont_var. */
- tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
- cont_var,
- build_zero_cst (boolean_type_node));
- tmp = gfc_unlikely (tmp, PRED_FORTRAN_CONTIGUOUS);
-
- if (pass_optional)
- {
- tree present_likely = gfc_likely (present_var,
- PRED_FORTRAN_ABSENT_DUMMY);
- post_cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
- boolean_type_node, present_likely,
- tmp);
- }
- else
- post_cond = tmp;
- }
- else
- {
- gcc_assert (pass_optional);
- post_cond = present_var;
- }
-
- tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
- post_stmts, build_empty_stmt (input_location));
- gfc_add_expr_to_block (&se->post, tmp);
- if (GFC_DESCRIPTOR_TYPE_P (type))
- {
- type = TREE_TYPE (parmse->expr);
- if (POINTER_TYPE_P (type))
- {
- pointer = gfc_build_addr_expr (type, pointer);
- if (pass_optional)
- {
- tmp = gfc_likely (present_var, PRED_FORTRAN_ABSENT_DUMMY);
- pointer = fold_build3_loc (input_location, COND_EXPR, type,
- tmp, pointer,
- fold_convert (type,
- null_pointer_node));
- }
- }
- else
- gcc_assert (!pass_optional);
- }
- se->expr = pointer;
- }
-
- return;
-}
-
-
-/* Generate the code for argument list functions. */
-
-static void
-conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
-{
- /* Pass by value for g77 %VAL(arg), pass the address
- indirectly for %LOC, else by reference. Thus %REF
- is a "do-nothing" and %LOC is the same as an F95
- pointer. */
- if (strcmp (name, "%VAL") == 0)
- gfc_conv_expr (se, expr);
- else if (strcmp (name, "%LOC") == 0)
- {
- gfc_conv_expr_reference (se, expr);
- se->expr = gfc_build_addr_expr (NULL, se->expr);
- }
- else if (strcmp (name, "%REF") == 0)
- gfc_conv_expr_reference (se, expr);
- else
- gfc_error ("Unknown argument list function at %L", &expr->where);
-}
-
-
-/* This function tells whether the middle-end representation of the expression
- E given as input may point to data otherwise accessible through a variable
- (sub-)reference.
- It is assumed that the only expressions that may alias are variables,
- and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
- may alias.
- This function is used to decide whether freeing an expression's allocatable
- components is safe or should be avoided.
-
- If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
- its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
- is necessary because for array constructors, aliasing depends on how
- the array is used:
- - If E is an array constructor used as argument to an elemental procedure,
- the array, which is generated through shallow copy by the scalarizer,
- is used directly and can alias the expressions it was copied from.
- - If E is an array constructor used as argument to a non-elemental
- procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
- the array as in the previous case, but then that array is used
- to initialize a new descriptor through deep copy. There is no alias
- possible in that case.
- Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
- above. */
-
-static bool
-expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
-{
- gfc_constructor *c;
-
- if (e->expr_type == EXPR_VARIABLE)
- return true;
- else if (e->expr_type == EXPR_FUNCTION)
- {
- gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
-
- if (proc_ifc->result != NULL
- && ((proc_ifc->result->ts.type == BT_CLASS
- && proc_ifc->result->ts.u.derived->attr.is_class
- && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
- || proc_ifc->result->attr.pointer))
- return true;
- else
- return false;
- }
- else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
- return false;
-
- for (c = gfc_constructor_first (e->value.constructor);
- c; c = gfc_constructor_next (c))
- if (c->expr
- && expr_may_alias_variables (c->expr, array_may_alias))
- return true;
-
- return false;
-}
-
-
-/* A helper function to set the dtype for unallocated or unassociated
- entities. */
-
-static void
-set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
-{
- tree tmp;
- tree desc;
- tree cond;
- tree type;
- stmtblock_t block;
-
- /* TODO Figure out how to handle optional dummies. */
- if (e && e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.optional)
- return;
-
- desc = parmse->expr;
- if (desc == NULL_TREE)
- return;
-
- if (POINTER_TYPE_P (TREE_TYPE (desc)))
- desc = build_fold_indirect_ref_loc (input_location, desc);
- if (GFC_CLASS_TYPE_P (TREE_TYPE (desc)))
- desc = gfc_class_data_get (desc);
- if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
- return;
-
- gfc_init_block (&block);
- tmp = gfc_conv_descriptor_data_get (desc);
- cond = fold_build2_loc (input_location, EQ_EXPR,
- logical_type_node, tmp,
- build_int_cst (TREE_TYPE (tmp), 0));
- tmp = gfc_conv_descriptor_dtype (desc);
- type = gfc_get_element_type (TREE_TYPE (desc));
- tmp = fold_build2_loc (input_location, MODIFY_EXPR,
- TREE_TYPE (tmp), tmp,
- gfc_get_dtype_rank_type (e->rank, type));
- gfc_add_expr_to_block (&block, tmp);
- cond = build3_v (COND_EXPR, cond,
- gfc_finish_block (&block),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&parmse->pre, cond);
-}
-
-
-
-/* Provide an interface between gfortran array descriptors and the F2018:18.4
- ISO_Fortran_binding array descriptors. */
-
-static void
-gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
-{
- stmtblock_t block, block2;
- tree cfi, gfc, tmp, tmp2;
- tree present = NULL;
- tree gfc_strlen = NULL;
- tree rank;
- gfc_se se;
-
- if (fsym->attr.optional
- && e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.optional)
- present = gfc_conv_expr_present (e->symtree->n.sym);
-
- gfc_init_block (&block);
-
- /* Convert original argument to a tree. */
- gfc_init_se (&se, NULL);
- if (e->rank == 0)
- {
- se.want_pointer = 1;
- gfc_conv_expr (&se, e);
- gfc = se.expr;
- /* gfc_conv_constant ignores se.want_poiner, e.g. for string_cst. */
- if (!POINTER_TYPE_P (TREE_TYPE (gfc)))
- gfc = gfc_build_addr_expr (NULL, gfc);
- }
- else
- {
- /* If the actual argument can be noncontiguous, copy-in/out is required,
- if the dummy has either the CONTIGUOUS attribute or is an assumed-
- length assumed-length/assumed-size CHARACTER array. This only
- applies if the actual argument is a "variable"; if it's some
- non-lvalue expression, we are going to evaluate it to a
- temporary below anyway. */
- se.force_no_tmp = 1;
- if ((fsym->attr.contiguous
- || (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length
- && (fsym->as->type == AS_ASSUMED_SIZE
- || fsym->as->type == AS_EXPLICIT)))
- && !gfc_is_simply_contiguous (e, false, true)
- && gfc_expr_is_variable (e))
- {
- bool optional = fsym->attr.optional;
- fsym->attr.optional = 0;
- gfc_conv_subref_array_arg (&se, e, false, fsym->attr.intent,
- fsym->attr.pointer, fsym,
- fsym->ns->proc_name->name, NULL,
- /* check_contiguous= */ true);
- fsym->attr.optional = optional;
- }
- else
- gfc_conv_expr_descriptor (&se, e);
- gfc = se.expr;
- /* For dt(:)%var the elem_len*stride != sm, hence, GFC uses
- elem_len = sizeof(dt) and base_addr = dt(lb) instead.
- gfc_get_dataptr_offset fixes the base_addr; for elem_len, see below.
- While sm is fine as it uses span*stride and not elem_len. */
- if (POINTER_TYPE_P (TREE_TYPE (gfc)))
- gfc = build_fold_indirect_ref_loc (input_location, gfc);
- else if (is_subref_array (e) && e->ts.type != BT_CHARACTER)
- gfc_get_dataptr_offset (&se.pre, gfc, gfc, NULL, true, e);
- }
- if (e->ts.type == BT_CHARACTER)
- {
- if (se.string_length)
- gfc_strlen = se.string_length;
- else if (e->ts.u.cl->backend_decl)
- gfc_strlen = e->ts.u.cl->backend_decl;
- else
- gcc_unreachable ();
- }
- gfc_add_block_to_block (&block, &se.pre);
-
- /* Create array decriptor and set version, rank, attribute, type. */
- cfi = gfc_create_var (gfc_get_cfi_type (e->rank < 0
- ? GFC_MAX_DIMENSIONS : e->rank,
- false), "cfi");
- /* Convert to CFI_cdesc_t, which has dim[] to avoid TBAA issues,*/
- if (fsym->attr.dimension && fsym->as->type == AS_ASSUMED_RANK)
- {
- tmp = gfc_get_cfi_type (-1, !fsym->attr.pointer && !fsym->attr.target);
- tmp = build_pointer_type (tmp);
- parmse->expr = cfi = gfc_build_addr_expr (tmp, cfi);
- cfi = build_fold_indirect_ref_loc (input_location, cfi);
- }
- else
- parmse->expr = gfc_build_addr_expr (NULL, cfi);
-
- tmp = gfc_get_cfi_desc_version (cfi);
- gfc_add_modify (&block, tmp,
- build_int_cst (TREE_TYPE (tmp), CFI_VERSION));
- if (e->rank < 0)
- rank = fold_convert (signed_char_type_node, gfc_conv_descriptor_rank (gfc));
- else
- rank = build_int_cst (signed_char_type_node, e->rank);
- tmp = gfc_get_cfi_desc_rank (cfi);
- gfc_add_modify (&block, tmp, rank);
- int itype = CFI_type_other;
- if (e->ts.f90_type == BT_VOID)
- itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
- ? CFI_type_cfunptr : CFI_type_cptr);
- else
- switch (e->ts.type)
- {
- case BT_INTEGER:
- case BT_LOGICAL:
- case BT_REAL:
- case BT_COMPLEX:
- itype = CFI_type_from_type_kind (e->ts.type, e->ts.kind);
- break;
- case BT_CHARACTER:
- itype = CFI_type_from_type_kind (CFI_type_Character, e->ts.kind);
- break;
- case BT_DERIVED:
- itype = CFI_type_struct;
- break;
- case BT_VOID:
- itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
- ? CFI_type_cfunptr : CFI_type_cptr);
- break;
- case BT_ASSUMED:
- itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
- break;
- case BT_CLASS:
- if (UNLIMITED_POLY (e) && fsym->ts.type == BT_ASSUMED)
- {
- // F2017: 7.3.2.2: "An entity that is declared using the TYPE(*)
- // type specifier is assumed-type and is an unlimited polymorphic
- // entity." The actual argument _data component is passed.
- itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
- break;
- }
- else
- gcc_unreachable ();
- case BT_PROCEDURE:
- case BT_HOLLERITH:
- case BT_UNION:
- case BT_BOZ:
- case BT_UNKNOWN:
- // FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other?
- gcc_unreachable ();
- }
-
- tmp = gfc_get_cfi_desc_type (cfi);
- gfc_add_modify (&block, tmp,
- build_int_cst (TREE_TYPE (tmp), itype));
-
- int attr = CFI_attribute_other;
- if (fsym->attr.pointer)
- attr = CFI_attribute_pointer;
- else if (fsym->attr.allocatable)
- attr = CFI_attribute_allocatable;
- tmp = gfc_get_cfi_desc_attribute (cfi);
- gfc_add_modify (&block, tmp,
- build_int_cst (TREE_TYPE (tmp), attr));
-
- if (e->rank == 0)
- {
- tmp = gfc_get_cfi_desc_base_addr (cfi);
- gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), gfc));
- }
- else
- {
- tmp = gfc_get_cfi_desc_base_addr (cfi);
- tmp2 = gfc_conv_descriptor_data_get (gfc);
- gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
- }
-
- /* Set elem_len if known - must be before the next if block.
- Note that allocatable implies 'len=:'. */
- if (e->ts.type != BT_ASSUMED && e->ts.type != BT_CHARACTER )
- {
- /* Length is known at compile time; use use 'block' for it. */
- tmp = size_in_bytes (gfc_typenode_for_spec (&e->ts));
- tmp2 = gfc_get_cfi_desc_elem_len (cfi);
- gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
- }
-
- /* When allocatable + intent out, free the cfi descriptor. */
- if (fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT)
- {
- tmp = gfc_get_cfi_desc_base_addr (cfi);
- tree call = builtin_decl_explicit (BUILT_IN_FREE);
- call = build_call_expr_loc (input_location, call, 1, tmp);
- gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
- gfc_add_modify (&block, tmp,
- fold_convert (TREE_TYPE (tmp), null_pointer_node));
- goto done;
- }
-
- /* If not unallocated/unassociated. */
- gfc_init_block (&block2);
-
- /* Set elem_len, which may be only known at run time. */
- if (e->ts.type == BT_CHARACTER)
- {
- gcc_assert (gfc_strlen);
- tmp = gfc_strlen;
- if (e->ts.kind != 1)
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_charlen_type_node, tmp,
- build_int_cst (gfc_charlen_type_node,
- e->ts.kind));
- tmp2 = gfc_get_cfi_desc_elem_len (cfi);
- gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
- }
- else if (e->ts.type == BT_ASSUMED)
- {
- tmp = gfc_conv_descriptor_elem_len (gfc);
- tmp2 = gfc_get_cfi_desc_elem_len (cfi);
- gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
- }
-
- if (e->ts.type == BT_ASSUMED)
- {
- /* Note: type(*) implies assumed-shape/assumed-rank if fsym requires
- an CFI descriptor. Use the type in the descritor as it provide
- mode information. (Quality of implementation feature.) */
- tree cond;
- tree ctype = gfc_get_cfi_desc_type (cfi);
- tree type = fold_convert (TREE_TYPE (ctype),
- gfc_conv_descriptor_type (gfc));
- tree kind = fold_convert (TREE_TYPE (ctype),
- gfc_conv_descriptor_elem_len (gfc));
- kind = fold_build2_loc (input_location, LSHIFT_EXPR, TREE_TYPE (type),
- kind, build_int_cst (TREE_TYPE (type),
- CFI_type_kind_shift));
-
- /* if (BT_VOID) CFI_type_cptr else CFI_type_other */
- /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
- build_int_cst (TREE_TYPE (type), BT_VOID));
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
- build_int_cst (TREE_TYPE (type), CFI_type_cptr));
- tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
- ctype,
- build_int_cst (TREE_TYPE (type), CFI_type_other));
- tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
- /* if (BT_DERIVED) CFI_type_struct else < tmp2 > */
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
- build_int_cst (TREE_TYPE (type), BT_DERIVED));
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
- build_int_cst (TREE_TYPE (type), CFI_type_struct));
- tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
- /* if (BT_CHARACTER) CFI_type_Character + kind=1 else < tmp2 > */
- /* Note: could also be kind=4, with cfi->elem_len = gfc->elem_len*4. */
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
- build_int_cst (TREE_TYPE (type), BT_CHARACTER));
- tmp = build_int_cst (TREE_TYPE (type),
- CFI_type_from_type_kind (CFI_type_Character, 1));
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
- ctype, tmp);
- tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
- /* if (BT_COMPLEX) CFI_type_Complex + kind/2 else < tmp2 > */
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
- build_int_cst (TREE_TYPE (type), BT_COMPLEX));
- tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (type),
- kind, build_int_cst (TREE_TYPE (type), 2));
- tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type), tmp,
- build_int_cst (TREE_TYPE (type),
- CFI_type_Complex));
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
- ctype, tmp);
- tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
- /* if (BT_INTEGER || BT_LOGICAL || BT_REAL) type + kind else <tmp2> */
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
- build_int_cst (TREE_TYPE (type), BT_INTEGER));
- tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
- build_int_cst (TREE_TYPE (type), BT_LOGICAL));
- cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
- cond, tmp);
- tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
- build_int_cst (TREE_TYPE (type), BT_REAL));
- cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
- cond, tmp);
- tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type),
- type, kind);
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
- ctype, tmp);
- tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
- gfc_add_expr_to_block (&block2, tmp2);
- }
-
- if (e->rank != 0)
- {
- /* Loop: for (i = 0; i < rank; ++i). */
- tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
- /* Loop body. */
- stmtblock_t loop_body;
- gfc_init_block (&loop_body);
- /* cfi->dim[i].lower_bound = (allocatable/pointer)
- ? gfc->dim[i].lbound : 0 */
- if (fsym->attr.pointer || fsym->attr.allocatable)
- tmp = gfc_conv_descriptor_lbound_get (gfc, idx);
- else
- tmp = gfc_index_zero_node;
- gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx), tmp);
- /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
- tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_ubound_get (gfc, idx),
- gfc_conv_descriptor_lbound_get (gfc, idx));
- tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- tmp, gfc_index_one_node);
- gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
- /* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
- tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_stride_get (gfc, idx),
- gfc_conv_descriptor_span_get (gfc));
- gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
-
- /* Generate loop. */
- gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
- rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
- gfc_finish_block (&loop_body));
-
- if (e->expr_type == EXPR_VARIABLE
- && e->ref
- && e->ref->u.ar.type == AR_FULL
- && e->symtree->n.sym->attr.dummy
- && e->symtree->n.sym->as
- && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
- {
- tmp = gfc_get_cfi_dim_extent (cfi, gfc_rank_cst[e->rank-1]),
- gfc_add_modify (&block2, tmp, build_int_cst (TREE_TYPE (tmp), -1));
- }
- }
-
- if (fsym->attr.allocatable || fsym->attr.pointer)
- {
- tmp = gfc_get_cfi_desc_base_addr (cfi),
- tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
- tmp, null_pointer_node);
- tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&block, tmp);
- }
- else
- gfc_add_block_to_block (&block, &block2);
-
-
-done:
- if (present)
- {
- parmse->expr = build3_loc (input_location, COND_EXPR,
- TREE_TYPE (parmse->expr),
- present, parmse->expr, null_pointer_node);
- tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&parmse->pre, tmp);
- }
- else
- gfc_add_block_to_block (&parmse->pre, &block);
-
- gfc_init_block (&block);
-
- if ((!fsym->attr.allocatable && !fsym->attr.pointer)
- || fsym->attr.intent == INTENT_IN)
- goto post_call;
-
- gfc_init_block (&block2);
- if (e->rank == 0)
- {
- tmp = gfc_get_cfi_desc_base_addr (cfi);
- gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
- }
- else
- {
- tmp = gfc_get_cfi_desc_base_addr (cfi);
- gfc_conv_descriptor_data_set (&block, gfc, tmp);
-
- if (fsym->attr.allocatable)
- {
- /* gfc->span = cfi->elem_len. */
- tmp = fold_convert (gfc_array_index_type,
- gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
- }
- else
- {
- /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
- ? cfi->dim[0].sm : cfi->elem_len). */
- tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
- tmp2 = fold_convert (gfc_array_index_type,
- gfc_get_cfi_desc_elem_len (cfi));
- tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
- gfc_array_index_type, tmp, tmp2);
- tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
- tmp, gfc_index_zero_node);
- tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
- gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
- }
- gfc_conv_descriptor_span_set (&block2, gfc, tmp);
-
- /* Calculate offset + set lbound, ubound and stride. */
- gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
- /* Loop: for (i = 0; i < rank; ++i). */
- tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
- /* Loop body. */
- stmtblock_t loop_body;
- gfc_init_block (&loop_body);
- /* gfc->dim[i].lbound = ... */
- tmp = gfc_get_cfi_dim_lbound (cfi, idx);
- gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
-
- /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
- tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_lbound_get (gfc, idx),
- gfc_index_one_node);
- tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- gfc_get_cfi_dim_extent (cfi, idx), tmp);
- gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
-
- /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
- tmp = gfc_get_cfi_dim_sm (cfi, idx);
- tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
- gfc_array_index_type, tmp,
- fold_convert (gfc_array_index_type,
- gfc_get_cfi_desc_elem_len (cfi)));
- gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
-
- /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
- tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_stride_get (gfc, idx),
- gfc_conv_descriptor_lbound_get (gfc, idx));
- tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_offset_get (gfc), tmp);
- gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
- /* Generate loop. */
- gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
- rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
- gfc_finish_block (&loop_body));
- }
-
- if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
- {
- tmp = fold_convert (gfc_charlen_type_node,
- gfc_get_cfi_desc_elem_len (cfi));
- if (e->ts.kind != 1)
- tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
- gfc_charlen_type_node, tmp,
- build_int_cst (gfc_charlen_type_node,
- e->ts.kind));
- gfc_add_modify (&block2, gfc_strlen, tmp);
- }
-
- tmp = gfc_get_cfi_desc_base_addr (cfi),
- tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
- tmp, null_pointer_node);
- tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&block, tmp);
-
-post_call:
- gfc_add_block_to_block (&block, &se.post);
- if (present && block.head)
- {
- tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&parmse->post, tmp);
- }
- else if (block.head)
- gfc_add_block_to_block (&parmse->post, &block);
-}
-
-
-/* Generate code for a procedure call. Note can return se->post != NULL.
- If se->direct_byref is set then se->expr contains the return parameter.
- Return nonzero, if the call has alternate specifiers.
- 'expr' is only needed for procedure pointer components. */
-
-int
-gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
- gfc_actual_arglist * args, gfc_expr * expr,
- vec<tree, va_gc> *append_args)
-{
- gfc_interface_mapping mapping;
- vec<tree, va_gc> *arglist;
- vec<tree, va_gc> *retargs;
- tree tmp;
- tree fntype;
- gfc_se parmse;
- gfc_array_info *info;
- int byref;
- int parm_kind;
- tree type;
- tree var;
- tree len;
- tree base_object;
- vec<tree, va_gc> *stringargs;
- vec<tree, va_gc> *optionalargs;
- tree result = NULL;
- gfc_formal_arglist *formal;
- gfc_actual_arglist *arg;
- int has_alternate_specifier = 0;
- bool need_interface_mapping;
- bool callee_alloc;
- bool ulim_copy;
- gfc_typespec ts;
- gfc_charlen cl;
- gfc_expr *e;
- gfc_symbol *fsym;
- stmtblock_t post;
- enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
- gfc_component *comp = NULL;
- int arglen;
- unsigned int argc;
-
- arglist = NULL;
- retargs = NULL;
- stringargs = NULL;
- optionalargs = NULL;
- var = NULL_TREE;
- len = NULL_TREE;
- gfc_clear_ts (&ts);
-
- comp = gfc_get_proc_ptr_comp (expr);
-
- bool elemental_proc = (comp
- && comp->ts.interface
- && comp->ts.interface->attr.elemental)
- || (comp && comp->attr.elemental)
- || sym->attr.elemental;
-
- if (se->ss != NULL)
- {
- if (!elemental_proc)
- {
- gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
- if (se->ss->info->useflags)
- {
- gcc_assert ((!comp && gfc_return_by_reference (sym)
- && sym->result->attr.dimension)
- || (comp && comp->attr.dimension)
- || gfc_is_class_array_function (expr));
- gcc_assert (se->loop != NULL);
- /* Access the previously obtained result. */
- gfc_conv_tmp_array_ref (se);
- return 0;
- }
- }
- info = &se->ss->info->data.array;
- }
- else
- info = NULL;
-
- gfc_init_block (&post);
- gfc_init_interface_mapping (&mapping);
- if (!comp)
- {
- formal = gfc_sym_get_dummy_args (sym);
- need_interface_mapping = sym->attr.dimension ||
- (sym->ts.type == BT_CHARACTER
- && sym->ts.u.cl->length
- && sym->ts.u.cl->length->expr_type
- != EXPR_CONSTANT);
- }
- else
- {
- formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
- need_interface_mapping = comp->attr.dimension ||
- (comp->ts.type == BT_CHARACTER
- && comp->ts.u.cl->length
- && comp->ts.u.cl->length->expr_type
- != EXPR_CONSTANT);
- }
-
- base_object = NULL_TREE;
- /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
- is the third and fourth argument to such a function call a value
- denoting the number of elements to copy (i.e., most of the time the
- length of a deferred length string). */
- ulim_copy = (formal == NULL)
- && UNLIMITED_POLY (sym)
- && comp && (strcmp ("_copy", comp->name) == 0);
-
- /* Evaluate the arguments. */
- for (arg = args, argc = 0; arg != NULL;
- arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
- {
- bool finalized = false;
- tree derived_array = NULL_TREE;
-
- e = arg->expr;
- fsym = formal ? formal->sym : NULL;
- parm_kind = MISSING;
-
- /* If the procedure requires an explicit interface, the actual
- argument is passed according to the corresponding formal
- argument. If the corresponding formal argument is a POINTER,
- ALLOCATABLE or assumed shape, we do not use g77's calling
- convention, and pass the address of the array descriptor
- instead. Otherwise we use g77's calling convention, in other words
- pass the array data pointer without descriptor. */
- bool nodesc_arg = fsym != NULL
- && !(fsym->attr.pointer || fsym->attr.allocatable)
- && fsym->as
- && fsym->as->type != AS_ASSUMED_SHAPE
- && fsym->as->type != AS_ASSUMED_RANK;
- if (comp)
- nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
- else
- nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
-
- /* Class array expressions are sometimes coming completely unadorned
- with either arrayspec or _data component. Correct that here.
- OOP-TODO: Move this to the frontend. */
- if (e && e->expr_type == EXPR_VARIABLE
- && !e->ref
- && e->ts.type == BT_CLASS
- && (CLASS_DATA (e)->attr.codimension
- || CLASS_DATA (e)->attr.dimension))
- {
- gfc_typespec temp_ts = e->ts;
- gfc_add_class_array_ref (e);
- e->ts = temp_ts;
- }
-
- if (e == NULL)
- {
- if (se->ignore_optional)
- {
- /* Some intrinsics have already been resolved to the correct
- parameters. */
- continue;
- }
- else if (arg->label)
- {
- has_alternate_specifier = 1;
- continue;
- }
- else
- {
- gfc_init_se (&parmse, NULL);
-
- /* For scalar arguments with VALUE attribute which are passed by
- value, pass "0" and a hidden argument gives the optional
- status. */
- if (fsym && fsym->attr.optional && fsym->attr.value
- && !fsym->attr.dimension && fsym->ts.type != BT_CHARACTER
- && fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED)
- {
- parmse.expr = fold_convert (gfc_sym_type (fsym),
- integer_zero_node);
- vec_safe_push (optionalargs, boolean_false_node);
- }
- else
- {
- /* Pass a NULL pointer for an absent arg. */
- parmse.expr = null_pointer_node;
- gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
- if (dummy_arg
- && gfc_dummy_arg_get_typespec (*dummy_arg).type
- == BT_CHARACTER)
- parmse.string_length = build_int_cst (gfc_charlen_type_node,
- 0);
- }
- }
- }
- else if (arg->expr->expr_type == EXPR_NULL
- && fsym && !fsym->attr.pointer
- && (fsym->ts.type != BT_CLASS
- || !CLASS_DATA (fsym)->attr.class_pointer))
- {
- /* Pass a NULL pointer to denote an absent arg. */
- gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
- && (fsym->ts.type != BT_CLASS
- || !CLASS_DATA (fsym)->attr.allocatable));
- gfc_init_se (&parmse, NULL);
- parmse.expr = null_pointer_node;
- if (arg->associated_dummy
- && gfc_dummy_arg_get_typespec (*arg->associated_dummy).type
- == BT_CHARACTER)
- parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
- }
- else if (fsym && fsym->ts.type == BT_CLASS
- && e->ts.type == BT_DERIVED)
- {
- /* The derived type needs to be converted to a temporary
- CLASS object. */
- gfc_init_se (&parmse, se);
- gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
- fsym->attr.optional
- && e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.optional,
- CLASS_DATA (fsym)->attr.class_pointer
- || CLASS_DATA (fsym)->attr.allocatable,
- &derived_array);
- }
- else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
- && e->ts.type != BT_PROCEDURE
- && (gfc_expr_attr (e).flavor != FL_PROCEDURE
- || gfc_expr_attr (e).proc != PROC_UNKNOWN))
- {
- /* The intrinsic type needs to be converted to a temporary
- CLASS object for the unlimited polymorphic formal. */
- gfc_find_vtab (&e->ts);
- gfc_init_se (&parmse, se);
- gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
-
- }
- else if (se->ss && se->ss->info->useflags)
- {
- gfc_ss *ss;
-
- ss = se->ss;
-
- /* An elemental function inside a scalarized loop. */
- gfc_init_se (&parmse, se);
- parm_kind = ELEMENTAL;
-
- /* When no fsym is present, ulim_copy is set and this is a third or
- fourth argument, use call-by-value instead of by reference to
- hand the length properties to the copy routine (i.e., most of the
- time this will be a call to a __copy_character_* routine where the
- third and fourth arguments are the lengths of a deferred length
- char array). */
- if ((fsym && fsym->attr.value)
- || (ulim_copy && (argc == 2 || argc == 3)))
- gfc_conv_expr (&parmse, e);
- else
- gfc_conv_expr_reference (&parmse, e);
-
- if (e->ts.type == BT_CHARACTER && !e->rank
- && e->expr_type == EXPR_FUNCTION)
- parmse.expr = build_fold_indirect_ref_loc (input_location,
- parmse.expr);
-
- if (fsym && fsym->ts.type == BT_DERIVED
- && gfc_is_class_container_ref (e))
- {
- parmse.expr = gfc_class_data_get (parmse.expr);
-
- if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.optional)
- {
- tree cond = gfc_conv_expr_present (e->symtree->n.sym);
- parmse.expr = build3_loc (input_location, COND_EXPR,
- TREE_TYPE (parmse.expr),
- cond, parmse.expr,
- fold_convert (TREE_TYPE (parmse.expr),
- null_pointer_node));
- }
- }
-
- /* If we are passing an absent array as optional dummy to an
- elemental procedure, make sure that we pass NULL when the data
- pointer is NULL. We need this extra conditional because of
- scalarization which passes arrays elements to the procedure,
- ignoring the fact that the array can be absent/unallocated/... */
- if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
- {
- tree descriptor_data;
-
- descriptor_data = ss->info->data.array.data;
- tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
- descriptor_data,
- fold_convert (TREE_TYPE (descriptor_data),
- null_pointer_node));
- parmse.expr
- = fold_build3_loc (input_location, COND_EXPR,
- TREE_TYPE (parmse.expr),
- gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
- fold_convert (TREE_TYPE (parmse.expr),
- null_pointer_node),
- parmse.expr);
- }
-
- /* The scalarizer does not repackage the reference to a class
- array - instead it returns a pointer to the data element. */
- if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
- gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
- fsym->attr.intent != INTENT_IN
- && (CLASS_DATA (fsym)->attr.class_pointer
- || CLASS_DATA (fsym)->attr.allocatable),
- fsym->attr.optional
- && e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.optional,
- CLASS_DATA (fsym)->attr.class_pointer
- || CLASS_DATA (fsym)->attr.allocatable);
- }
- else
- {
- bool scalar;
- gfc_ss *argss;
-
- gfc_init_se (&parmse, NULL);
-
- /* Check whether the expression is a scalar or not; we cannot use
- e->rank as it can be nonzero for functions arguments. */
- argss = gfc_walk_expr (e);
- scalar = argss == gfc_ss_terminator;
- if (!scalar)
- gfc_free_ss_chain (argss);
-
- /* Special handling for passing scalar polymorphic coarrays;
- otherwise one passes "class->_data.data" instead of "&class". */
- if (e->rank == 0 && e->ts.type == BT_CLASS
- && fsym && fsym->ts.type == BT_CLASS
- && CLASS_DATA (fsym)->attr.codimension
- && !CLASS_DATA (fsym)->attr.dimension)
- {
- gfc_add_class_array_ref (e);
- parmse.want_coarray = 1;
- scalar = false;
- }
-
- /* A scalar or transformational function. */
- if (scalar)
- {
- if (e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.cray_pointee
- && fsym && fsym->attr.flavor == FL_PROCEDURE)
- {
- /* The Cray pointer needs to be converted to a pointer to
- a type given by the expression. */
- gfc_conv_expr (&parmse, e);
- type = build_pointer_type (TREE_TYPE (parmse.expr));
- tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
- parmse.expr = convert (type, tmp);
- }
-
- else if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
- /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
- gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
-
- else if (fsym && fsym->attr.value)
- {
- if (fsym->ts.type == BT_CHARACTER
- && fsym->ts.is_c_interop
- && fsym->ns->proc_name != NULL
- && fsym->ns->proc_name->attr.is_bind_c)
- {
- parmse.expr = NULL;
- conv_scalar_char_value (fsym, &parmse, &e);
- if (parmse.expr == NULL)
- gfc_conv_expr (&parmse, e);
- }
- else
- {
- gfc_conv_expr (&parmse, e);
- if (fsym->attr.optional
- && fsym->ts.type != BT_CLASS
- && fsym->ts.type != BT_DERIVED)
- {
- if (e->expr_type != EXPR_VARIABLE
- || !e->symtree->n.sym->attr.optional
- || e->ref != NULL)
- vec_safe_push (optionalargs, boolean_true_node);
- else
- {
- tmp = gfc_conv_expr_present (e->symtree->n.sym);
- if (!e->symtree->n.sym->attr.value)
- parmse.expr
- = fold_build3_loc (input_location, COND_EXPR,
- TREE_TYPE (parmse.expr),
- tmp, parmse.expr,
- fold_convert (TREE_TYPE (parmse.expr),
- integer_zero_node));
-
- vec_safe_push (optionalargs,
- fold_convert (boolean_type_node,
- tmp));
- }
- }
- }
- }
-
- else if (arg->name && arg->name[0] == '%')
- /* Argument list functions %VAL, %LOC and %REF are signalled
- through arg->name. */
- conv_arglist_function (&parmse, arg->expr, arg->name);
- else if ((e->expr_type == EXPR_FUNCTION)
- && ((e->value.function.esym
- && e->value.function.esym->result->attr.pointer)
- || (!e->value.function.esym
- && e->symtree->n.sym->attr.pointer))
- && fsym && fsym->attr.target)
- /* Make sure the function only gets called once. */
- gfc_conv_expr_reference (&parmse, e, false);
- else if (e->expr_type == EXPR_FUNCTION
- && e->symtree->n.sym->result
- && e->symtree->n.sym->result != e->symtree->n.sym
- && e->symtree->n.sym->result->attr.proc_pointer)
- {
- /* Functions returning procedure pointers. */
- gfc_conv_expr (&parmse, e);
- if (fsym && fsym->attr.proc_pointer)
- parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
- }
-
- else
- {
- if (e->ts.type == BT_CLASS && fsym
- && fsym->ts.type == BT_CLASS
- && (!CLASS_DATA (fsym)->as
- || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
- && CLASS_DATA (e)->attr.codimension)
- {
- gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
- gcc_assert (!CLASS_DATA (fsym)->as);
- gfc_add_class_array_ref (e);
- parmse.want_coarray = 1;
- gfc_conv_expr_reference (&parmse, e);
- class_scalar_coarray_to_class (&parmse, e, fsym->ts,
- fsym->attr.optional
- && e->expr_type == EXPR_VARIABLE);
- }
- else if (e->ts.type == BT_CLASS && fsym
- && fsym->ts.type == BT_CLASS
- && !CLASS_DATA (fsym)->as
- && !CLASS_DATA (e)->as
- && strcmp (fsym->ts.u.derived->name,
- e->ts.u.derived->name))
- {
- type = gfc_typenode_for_spec (&fsym->ts);
- var = gfc_create_var (type, fsym->name);
- gfc_conv_expr (&parmse, e);
- if (fsym->attr.optional
- && e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.optional)
- {
- stmtblock_t block;
- tree cond;
- tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
- cond = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node, tmp,
- fold_convert (TREE_TYPE (tmp),
- null_pointer_node));
- gfc_start_block (&block);
- gfc_add_modify (&block, var,
- fold_build1_loc (input_location,
- VIEW_CONVERT_EXPR,
- type, parmse.expr));
- gfc_add_expr_to_block (&parmse.pre,
- fold_build3_loc (input_location,
- COND_EXPR, void_type_node,
- cond, gfc_finish_block (&block),
- build_empty_stmt (input_location)));
- parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
- parmse.expr = build3_loc (input_location, COND_EXPR,
- TREE_TYPE (parmse.expr),
- cond, parmse.expr,
- fold_convert (TREE_TYPE (parmse.expr),
- null_pointer_node));
- }
- else
- {
- /* Since the internal representation of unlimited
- polymorphic expressions includes an extra field
- that other class objects do not, a cast to the
- formal type does not work. */
- if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
- {
- tree efield;
-
- /* Set the _data field. */
- tmp = gfc_class_data_get (var);
- efield = fold_convert (TREE_TYPE (tmp),
- gfc_class_data_get (parmse.expr));
- gfc_add_modify (&parmse.pre, tmp, efield);
-
- /* Set the _vptr field. */
- tmp = gfc_class_vptr_get (var);
- efield = fold_convert (TREE_TYPE (tmp),
- gfc_class_vptr_get (parmse.expr));
- gfc_add_modify (&parmse.pre, tmp, efield);
-
- /* Set the _len field. */
- tmp = gfc_class_len_get (var);
- gfc_add_modify (&parmse.pre, tmp,
- build_int_cst (TREE_TYPE (tmp), 0));
- }
- else
- {
- tmp = fold_build1_loc (input_location,
- VIEW_CONVERT_EXPR,
- type, parmse.expr);
- gfc_add_modify (&parmse.pre, var, tmp);
- ;
- }
- parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
- }
- }
- else
- {
- bool add_clobber;
- add_clobber = fsym && fsym->attr.intent == INTENT_OUT
- && !fsym->attr.allocatable && !fsym->attr.pointer
- && e->symtree && e->symtree->n.sym
- && !e->symtree->n.sym->attr.dimension
- && !e->symtree->n.sym->attr.pointer
- && !e->symtree->n.sym->attr.allocatable
- /* See PR 41453. */
- && !e->symtree->n.sym->attr.dummy
- /* FIXME - PR 87395 and PR 41453 */
- && e->symtree->n.sym->attr.save == SAVE_NONE
- && !e->symtree->n.sym->attr.associate_var
- && e->ts.type != BT_CHARACTER && e->ts.type != BT_DERIVED
- && e->ts.type != BT_CLASS && !sym->attr.elemental;
-
- gfc_conv_expr_reference (&parmse, e, add_clobber);
- }
- /* Catch base objects that are not variables. */
- if (e->ts.type == BT_CLASS
- && e->expr_type != EXPR_VARIABLE
- && expr && e == expr->base_expr)
- base_object = build_fold_indirect_ref_loc (input_location,
- parmse.expr);
-
- /* A class array element needs converting back to be a
- class object, if the formal argument is a class object. */
- if (fsym && fsym->ts.type == BT_CLASS
- && e->ts.type == BT_CLASS
- && ((CLASS_DATA (fsym)->as
- && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
- || CLASS_DATA (e)->attr.dimension))
- gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
- fsym->attr.intent != INTENT_IN
- && (CLASS_DATA (fsym)->attr.class_pointer
- || CLASS_DATA (fsym)->attr.allocatable),
- fsym->attr.optional
- && e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.optional,
- CLASS_DATA (fsym)->attr.class_pointer
- || CLASS_DATA (fsym)->attr.allocatable);
-
- /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
- allocated on entry, it must be deallocated. */
- if (fsym && fsym->attr.intent == INTENT_OUT
- && (fsym->attr.allocatable
- || (fsym->ts.type == BT_CLASS
- && CLASS_DATA (fsym)->attr.allocatable))
- && !is_CFI_desc (fsym, NULL))
- {
- stmtblock_t block;
- tree ptr;
-
- gfc_init_block (&block);
- ptr = parmse.expr;
- if (e->ts.type == BT_CLASS)
- ptr = gfc_class_data_get (ptr);
-
- tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
- NULL_TREE, true,
- e, e->ts);
- gfc_add_expr_to_block (&block, tmp);
- tmp = fold_build2_loc (input_location, MODIFY_EXPR,
- void_type_node, ptr,
- null_pointer_node);
- gfc_add_expr_to_block (&block, tmp);
-
- if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
- {
- gfc_add_modify (&block, ptr,
- fold_convert (TREE_TYPE (ptr),
- null_pointer_node));
- gfc_add_expr_to_block (&block, tmp);
- }
- else if (fsym->ts.type == BT_CLASS)
- {
- gfc_symbol *vtab;
- vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
- tmp = gfc_get_symbol_decl (vtab);
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
- ptr = gfc_class_vptr_get (parmse.expr);
- gfc_add_modify (&block, ptr,
- fold_convert (TREE_TYPE (ptr), tmp));
- gfc_add_expr_to_block (&block, tmp);
- }
-
- if (fsym->attr.optional
- && e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.optional)
- {
- tmp = fold_build3_loc (input_location, COND_EXPR,
- void_type_node,
- gfc_conv_expr_present (e->symtree->n.sym),
- gfc_finish_block (&block),
- build_empty_stmt (input_location));
- }
- else
- tmp = gfc_finish_block (&block);
-
- gfc_add_expr_to_block (&se->pre, tmp);
- }
-
- if (fsym && (fsym->ts.type == BT_DERIVED
- || fsym->ts.type == BT_ASSUMED)
- && e->ts.type == BT_CLASS
- && !CLASS_DATA (e)->attr.dimension
- && !CLASS_DATA (e)->attr.codimension)
- {
- parmse.expr = gfc_class_data_get (parmse.expr);
- /* The result is a class temporary, whose _data component
- must be freed to avoid a memory leak. */
- if (e->expr_type == EXPR_FUNCTION
- && CLASS_DATA (e)->attr.allocatable)
- {
- tree zero;
-
- gfc_expr *var;
-
- /* Borrow the function symbol to make a call to
- gfc_add_finalizer_call and then restore it. */
- tmp = e->symtree->n.sym->backend_decl;
- e->symtree->n.sym->backend_decl
- = TREE_OPERAND (parmse.expr, 0);
- e->symtree->n.sym->attr.flavor = FL_VARIABLE;
- var = gfc_lval_expr_from_sym (e->symtree->n.sym);
- finalized = gfc_add_finalizer_call (&parmse.post,
- var);
- gfc_free_expr (var);
- e->symtree->n.sym->backend_decl = tmp;
- e->symtree->n.sym->attr.flavor = FL_PROCEDURE;
-
- /* Then free the class _data. */
- zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
- tmp = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node,
- parmse.expr, zero);
- tmp = build3_v (COND_EXPR, tmp,
- gfc_call_free (parmse.expr),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&parmse.post, tmp);
- gfc_add_modify (&parmse.post, parmse.expr, zero);
- }
- }
-
- /* Wrap scalar variable in a descriptor. We need to convert
- the address of a pointer back to the pointer itself before,
- we can assign it to the data field. */
-
- if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
- && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
- {
- tmp = parmse.expr;
- if (TREE_CODE (tmp) == ADDR_EXPR)
- tmp = TREE_OPERAND (tmp, 0);
- parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
- fsym->attr);
- parmse.expr = gfc_build_addr_expr (NULL_TREE,
- parmse.expr);
- }
- else if (fsym && e->expr_type != EXPR_NULL
- && ((fsym->attr.pointer
- && fsym->attr.flavor != FL_PROCEDURE)
- || (fsym->attr.proc_pointer
- && !(e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.dummy))
- || (fsym->attr.proc_pointer
- && e->expr_type == EXPR_VARIABLE
- && gfc_is_proc_ptr_comp (e))
- || (fsym->attr.allocatable
- && fsym->attr.flavor != FL_PROCEDURE)))
- {
- /* Scalar pointer dummy args require an extra level of
- indirection. The null pointer already contains
- this level of indirection. */
- parm_kind = SCALAR_POINTER;
- parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
- }
- }
- }
- else if (e->ts.type == BT_CLASS
- && fsym && fsym->ts.type == BT_CLASS
- && (CLASS_DATA (fsym)->attr.dimension
- || CLASS_DATA (fsym)->attr.codimension))
- {
- /* Pass a class array. */
- parmse.use_offset = 1;
- gfc_conv_expr_descriptor (&parmse, e);
-
- /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
- allocated on entry, it must be deallocated. */
- if (fsym->attr.intent == INTENT_OUT
- && CLASS_DATA (fsym)->attr.allocatable)
- {
- stmtblock_t block;
- tree ptr;
-
- gfc_init_block (&block);
- ptr = parmse.expr;
- ptr = gfc_class_data_get (ptr);
-
- tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
- NULL_TREE, NULL_TREE,
- NULL_TREE, true, e,
- GFC_CAF_COARRAY_NOCOARRAY);
- gfc_add_expr_to_block (&block, tmp);
- tmp = fold_build2_loc (input_location, MODIFY_EXPR,
- void_type_node, ptr,
- null_pointer_node);
- gfc_add_expr_to_block (&block, tmp);
- gfc_reset_vptr (&block, e);
-
- if (fsym->attr.optional
- && e->expr_type == EXPR_VARIABLE
- && (!e->ref
- || (e->ref->type == REF_ARRAY
- && e->ref->u.ar.type != AR_FULL))
- && e->symtree->n.sym->attr.optional)
- {
- tmp = fold_build3_loc (input_location, COND_EXPR,
- void_type_node,
- gfc_conv_expr_present (e->symtree->n.sym),
- gfc_finish_block (&block),
- build_empty_stmt (input_location));
- }
- else
- tmp = gfc_finish_block (&block);
-
- gfc_add_expr_to_block (&se->pre, tmp);
- }
-
- /* The conversion does not repackage the reference to a class
- array - _data descriptor. */
- gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
- fsym->attr.intent != INTENT_IN
- && (CLASS_DATA (fsym)->attr.class_pointer
- || CLASS_DATA (fsym)->attr.allocatable),
- fsym->attr.optional
- && e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.optional,
- CLASS_DATA (fsym)->attr.class_pointer
- || CLASS_DATA (fsym)->attr.allocatable);
- }
- else
- {
- /* If the argument is a function call that may not create
- a temporary for the result, we have to check that we
- can do it, i.e. that there is no alias between this
- argument and another one. */
- if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
- {
- gfc_expr *iarg;
- sym_intent intent;
-
- if (fsym != NULL)
- intent = fsym->attr.intent;
- else
- intent = INTENT_UNKNOWN;
-
- if (gfc_check_fncall_dependency (e, intent, sym, args,
- NOT_ELEMENTAL))
- parmse.force_tmp = 1;
-
- iarg = e->value.function.actual->expr;
-
- /* Temporary needed if aliasing due to host association. */
- if (sym->attr.contained
- && !sym->attr.pure
- && !sym->attr.implicit_pure
- && !sym->attr.use_assoc
- && iarg->expr_type == EXPR_VARIABLE
- && sym->ns == iarg->symtree->n.sym->ns)
- parmse.force_tmp = 1;
-
- /* Ditto within module. */
- if (sym->attr.use_assoc
- && !sym->attr.pure
- && !sym->attr.implicit_pure
- && iarg->expr_type == EXPR_VARIABLE
- && sym->module == iarg->symtree->n.sym->module)
- parmse.force_tmp = 1;
- }
-
- /* Special case for assumed-rank arrays: when passing an
- argument to a nonallocatable/nonpointer dummy, the bounds have
- to be reset as otherwise a last-dim ubound of -1 is
- indistinguishable from an assumed-size array in the callee. */
- if (!sym->attr.is_bind_c && e && fsym && fsym->as
- && fsym->as->type == AS_ASSUMED_RANK
- && e->rank != -1
- && e->expr_type == EXPR_VARIABLE
- && ((fsym->ts.type == BT_CLASS
- && !CLASS_DATA (fsym)->attr.class_pointer
- && !CLASS_DATA (fsym)->attr.allocatable)
- || (fsym->ts.type != BT_CLASS
- && !fsym->attr.pointer && !fsym->attr.allocatable)))
- {
- /* Change AR_FULL to a (:,:,:) ref to force bounds update. */
- gfc_ref *ref;
- for (ref = e->ref; ref->next; ref = ref->next)
- ;
- if (ref->u.ar.type == AR_FULL
- && ref->u.ar.as->type != AS_ASSUMED_SIZE)
- ref->u.ar.type = AR_SECTION;
- }
-
- if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
- /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
- gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
-
- else if (e->expr_type == EXPR_VARIABLE
- && is_subref_array (e)
- && !(fsym && fsym->attr.pointer))
- /* The actual argument is a component reference to an
- array of derived types. In this case, the argument
- is converted to a temporary, which is passed and then
- written back after the procedure call. */
- gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
- fsym ? fsym->attr.intent : INTENT_INOUT,
- fsym && fsym->attr.pointer);
-
- else if (e->ts.type == BT_CLASS && CLASS_DATA (e)->as
- && CLASS_DATA (e)->as->type == AS_ASSUMED_SIZE
- && nodesc_arg && fsym->ts.type == BT_DERIVED)
- /* An assumed size class actual argument being passed to
- a 'no descriptor' formal argument just requires the
- data pointer to be passed. For class dummy arguments
- this is stored in the symbol backend decl.. */
- parmse.expr = e->symtree->n.sym->backend_decl;
-
- else if (gfc_is_class_array_ref (e, NULL)
- && fsym && fsym->ts.type == BT_DERIVED)
- /* The actual argument is a component reference to an
- array of derived types. In this case, the argument
- is converted to a temporary, which is passed and then
- written back after the procedure call.
- OOP-TODO: Insert code so that if the dynamic type is
- the same as the declared type, copy-in/copy-out does
- not occur. */
- gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
- fsym->attr.intent,
- fsym->attr.pointer);
-
- else if (gfc_is_class_array_function (e)
- && fsym && fsym->ts.type == BT_DERIVED)
- /* See previous comment. For function actual argument,
- the write out is not needed so the intent is set as
- intent in. */
- {
- e->must_finalize = 1;
- gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
- INTENT_IN, fsym->attr.pointer);
- }
- else if (fsym && fsym->attr.contiguous
- && !gfc_is_simply_contiguous (e, false, true)
- && gfc_expr_is_variable (e))
- {
- gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
- fsym->attr.intent,
- fsym->attr.pointer);
- }
- else
- /* This is where we introduce a temporary to store the
- result of a non-lvalue array expression. */
- gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
- sym->name, NULL);
-
- /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
- allocated on entry, it must be deallocated.
- CFI descriptors are handled elsewhere. */
- if (fsym && fsym->attr.allocatable
- && fsym->attr.intent == INTENT_OUT
- && !is_CFI_desc (fsym, NULL))
- {
- if (fsym->ts.type == BT_DERIVED
- && fsym->ts.u.derived->attr.alloc_comp)
- {
- // deallocate the components first
- tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
- parmse.expr, e->rank);
- /* But check whether dummy argument is optional. */
- if (tmp != NULL_TREE
- && fsym->attr.optional
- && e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.optional)
- {
- tree present;
- present = gfc_conv_expr_present (e->symtree->n.sym);
- tmp = build3_v (COND_EXPR, present, tmp,
- build_empty_stmt (input_location));
- }
- if (tmp != NULL_TREE)
- gfc_add_expr_to_block (&se->pre, tmp);
- }
-
- tmp = parmse.expr;
- /* With bind(C), the actual argument is replaced by a bind-C
- descriptor; in this case, the data component arrives here,
- which shall not be dereferenced, but still freed and
- nullified. */
- if (TREE_TYPE(tmp) != pvoid_type_node)
- tmp = build_fold_indirect_ref_loc (input_location,
- parmse.expr);
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
- tmp = gfc_conv_descriptor_data_get (tmp);
- tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
- NULL_TREE, NULL_TREE, true,
- e,
- GFC_CAF_COARRAY_NOCOARRAY);
- if (fsym->attr.optional
- && e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.optional)
- tmp = fold_build3_loc (input_location, COND_EXPR,
- void_type_node,
- gfc_conv_expr_present (e->symtree->n.sym),
- tmp, build_empty_stmt (input_location));
- gfc_add_expr_to_block (&se->pre, tmp);
- }
- }
- }
- /* Special case for an assumed-rank dummy argument. */
- if (!sym->attr.is_bind_c && e && fsym && e->rank > 0
- && (fsym->ts.type == BT_CLASS
- ? (CLASS_DATA (fsym)->as
- && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
- : (fsym->as && fsym->as->type == AS_ASSUMED_RANK)))
- {
- if (fsym->ts.type == BT_CLASS
- ? (CLASS_DATA (fsym)->attr.class_pointer
- || CLASS_DATA (fsym)->attr.allocatable)
- : (fsym->attr.pointer || fsym->attr.allocatable))
- {
- /* Unallocated allocatable arrays and unassociated pointer
- arrays need their dtype setting if they are argument
- associated with assumed rank dummies to set the rank. */
- set_dtype_for_unallocated (&parmse, e);
- }
- else if (e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.dummy
- && (e->ts.type == BT_CLASS
- ? (e->ref && e->ref->next
- && e->ref->next->type == REF_ARRAY
- && e->ref->next->u.ar.type == AR_FULL
- && e->ref->next->u.ar.as->type == AS_ASSUMED_SIZE)
- : (e->ref && e->ref->type == REF_ARRAY
- && e->ref->u.ar.type == AR_FULL
- && e->ref->u.ar.as->type == AS_ASSUMED_SIZE)))
- {
- /* Assumed-size actual to assumed-rank dummy requires
- dim[rank-1].ubound = -1. */
- tree minus_one;
- tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
- if (fsym->ts.type == BT_CLASS)
- tmp = gfc_class_data_get (tmp);
- minus_one = build_int_cst (gfc_array_index_type, -1);
- gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
- gfc_rank_cst[e->rank - 1],
- minus_one);
- }
- }
-
- /* The case with fsym->attr.optional is that of a user subroutine
- with an interface indicating an optional argument. When we call
- an intrinsic subroutine, however, fsym is NULL, but we might still
- have an optional argument, so we proceed to the substitution
- just in case. */
- if (e && (fsym == NULL || fsym->attr.optional))
- {
- /* If an optional argument is itself an optional dummy argument,
- check its presence and substitute a null if absent. This is
- only needed when passing an array to an elemental procedure
- as then array elements are accessed - or no NULL pointer is
- allowed and a "1" or "0" should be passed if not present.
- When passing a non-array-descriptor full array to a
- non-array-descriptor dummy, no check is needed. For
- array-descriptor actual to array-descriptor dummy, see
- PR 41911 for why a check has to be inserted.
- fsym == NULL is checked as intrinsics required the descriptor
- but do not always set fsym.
- Also, it is necessary to pass a NULL pointer to library routines
- which usually ignore optional arguments, so they can handle
- these themselves. */
- if (e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.optional
- && (((e->rank != 0 && elemental_proc)
- || e->representation.length || e->ts.type == BT_CHARACTER
- || (e->rank != 0
- && (fsym == NULL
- || (fsym->as
- && (fsym->as->type == AS_ASSUMED_SHAPE
- || fsym->as->type == AS_ASSUMED_RANK
- || fsym->as->type == AS_DEFERRED)))))
- || se->ignore_optional))
- gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
- e->representation.length);
- }
-
- if (fsym && e)
- {
- /* Obtain the character length of an assumed character length
- length procedure from the typespec. */
- if (fsym->ts.type == BT_CHARACTER
- && parmse.string_length == NULL_TREE
- && e->ts.type == BT_PROCEDURE
- && e->symtree->n.sym->ts.type == BT_CHARACTER
- && e->symtree->n.sym->ts.u.cl->length != NULL
- && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
- {
- gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
- parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
- }
- }
-
- if (fsym && need_interface_mapping && e)
- gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
-
- gfc_add_block_to_block (&se->pre, &parmse.pre);
- gfc_add_block_to_block (&post, &parmse.post);
-
- /* Allocated allocatable components of derived types must be
- deallocated for non-variable scalars, array arguments to elemental
- procedures, and array arguments with descriptor to non-elemental
- procedures. As bounds information for descriptorless arrays is no
- longer available here, they are dealt with in trans-array.c
- (gfc_conv_array_parameter). */
- if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
- && e->ts.u.derived->attr.alloc_comp
- && (e->rank == 0 || elemental_proc || !nodesc_arg)
- && !expr_may_alias_variables (e, elemental_proc))
- {
- int parm_rank;
- /* It is known the e returns a structure type with at least one
- allocatable component. When e is a function, ensure that the
- function is called once only by using a temporary variable. */
- if (!DECL_P (parmse.expr))
- parmse.expr = gfc_evaluate_now_loc (input_location,
- parmse.expr, &se->pre);
-
- if (fsym && fsym->attr.value)
- tmp = parmse.expr;
- else
- tmp = build_fold_indirect_ref_loc (input_location,
- parmse.expr);
-
- parm_rank = e->rank;
- switch (parm_kind)
- {
- case (ELEMENTAL):
- case (SCALAR):
- parm_rank = 0;
- break;
-
- case (SCALAR_POINTER):
- tmp = build_fold_indirect_ref_loc (input_location,
- tmp);
- break;
- }
-
- if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
- {
- /* The derived type is passed to gfc_deallocate_alloc_comp.
- Therefore, class actuals can be handled correctly but derived
- types passed to class formals need the _data component. */
- tmp = gfc_class_data_get (tmp);
- if (!CLASS_DATA (fsym)->attr.dimension)
- tmp = build_fold_indirect_ref_loc (input_location, tmp);
- }
-
- if (e->expr_type == EXPR_OP
- && e->value.op.op == INTRINSIC_PARENTHESES
- && e->value.op.op1->expr_type == EXPR_VARIABLE)
- {
- tree local_tmp;
- local_tmp = gfc_evaluate_now (tmp, &se->pre);
- local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
- parm_rank, 0);
- gfc_add_expr_to_block (&se->post, local_tmp);
- }
-
- if (!finalized && !e->must_finalize)
- {
- bool scalar_res_outside_loop;
- scalar_res_outside_loop = e->expr_type == EXPR_FUNCTION
- && parm_rank == 0
- && parmse.loop;
-
- /* Scalars passed to an assumed rank argument are converted to
- a descriptor. Obtain the data field before deallocating any
- allocatable components. */
- if (parm_rank == 0 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
- tmp = gfc_conv_descriptor_data_get (tmp);
-
- if (scalar_res_outside_loop)
- {
- /* Go through the ss chain to find the argument and use
- the stored value. */
- gfc_ss *tmp_ss = parmse.loop->ss;
- for (; tmp_ss; tmp_ss = tmp_ss->next)
- if (tmp_ss->info
- && tmp_ss->info->expr == e
- && tmp_ss->info->data.scalar.value != NULL_TREE)
- {
- tmp = tmp_ss->info->data.scalar.value;
- break;
- }
- }
-
- STRIP_NOPS (tmp);
-
- if (derived_array != NULL_TREE)
- tmp = gfc_deallocate_alloc_comp (e->ts.u.derived,
- derived_array,
- parm_rank);
- else if ((e->ts.type == BT_CLASS
- && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
- || e->ts.type == BT_DERIVED)
- tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
- parm_rank);
- else if (e->ts.type == BT_CLASS)
- tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
- tmp, parm_rank);
-
- if (scalar_res_outside_loop)
- gfc_add_expr_to_block (&parmse.loop->post, tmp);
- else
- gfc_prepend_expr_to_block (&post, tmp);
- }
- }
-
- /* Add argument checking of passing an unallocated/NULL actual to
- a nonallocatable/nonpointer dummy. */
-
- if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
- {
- symbol_attribute attr;
- char *msg;
- tree cond;
- tree tmp;
- symbol_attribute fsym_attr;
-
- if (fsym)
- {
- if (fsym->ts.type == BT_CLASS)
- {
- fsym_attr = CLASS_DATA (fsym)->attr;
- fsym_attr.pointer = fsym_attr.class_pointer;
- }
- else
- fsym_attr = fsym->attr;
- }
-
- if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
- attr = gfc_expr_attr (e);
- else
- goto end_pointer_check;
-
- /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
- allocatable to an optional dummy, cf. 12.5.2.12. */
- if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
- && (gfc_option.allow_std & GFC_STD_F2008) != 0)
- goto end_pointer_check;
-
- if (attr.optional)
- {
- /* If the actual argument is an optional pointer/allocatable and
- the formal argument takes an nonpointer optional value,
- it is invalid to pass a non-present argument on, even
- though there is no technical reason for this in gfortran.
- See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
- tree present, null_ptr, type;
-
- if (attr.allocatable
- && (fsym == NULL || !fsym_attr.allocatable))
- msg = xasprintf ("Allocatable actual argument '%s' is not "
- "allocated or not present",
- e->symtree->n.sym->name);
- else if (attr.pointer
- && (fsym == NULL || !fsym_attr.pointer))
- msg = xasprintf ("Pointer actual argument '%s' is not "
- "associated or not present",
- e->symtree->n.sym->name);
- else if (attr.proc_pointer && !e->value.function.actual
- && (fsym == NULL || !fsym_attr.proc_pointer))
- msg = xasprintf ("Proc-pointer actual argument '%s' is not "
- "associated or not present",
- e->symtree->n.sym->name);
- else
- goto end_pointer_check;
-
- present = gfc_conv_expr_present (e->symtree->n.sym);
- type = TREE_TYPE (present);
- present = fold_build2_loc (input_location, EQ_EXPR,
- logical_type_node, present,
- fold_convert (type,
- null_pointer_node));
- type = TREE_TYPE (parmse.expr);
- null_ptr = fold_build2_loc (input_location, EQ_EXPR,
- logical_type_node, parmse.expr,
- fold_convert (type,
- null_pointer_node));
- cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
- logical_type_node, present, null_ptr);
- }
- else
- {
- if (attr.allocatable
- && (fsym == NULL || !fsym_attr.allocatable))
- msg = xasprintf ("Allocatable actual argument '%s' is not "
- "allocated", e->symtree->n.sym->name);
- else if (attr.pointer
- && (fsym == NULL || !fsym_attr.pointer))
- msg = xasprintf ("Pointer actual argument '%s' is not "
- "associated", e->symtree->n.sym->name);
- else if (attr.proc_pointer && !e->value.function.actual
- && (fsym == NULL || !fsym_attr.proc_pointer))
- msg = xasprintf ("Proc-pointer actual argument '%s' is not "
- "associated", e->symtree->n.sym->name);
- else
- goto end_pointer_check;
-
- if (fsym && fsym->ts.type == BT_CLASS)
- {
- tmp = build_fold_indirect_ref_loc (input_location,
- parmse.expr);
- tmp = gfc_class_data_get (tmp);
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
- tmp = gfc_conv_descriptor_data_get (tmp);
- }
- else
- tmp = parmse.expr;
-
- /* If the argument is passed by value, we need to strip the
- INDIRECT_REF. */
- if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
-
- cond = fold_build2_loc (input_location, EQ_EXPR,
- logical_type_node, tmp,
- fold_convert (TREE_TYPE (tmp),
- null_pointer_node));
- }
-
- gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
- msg);
- free (msg);
- }
- end_pointer_check:
-
- /* Deferred length dummies pass the character length by reference
- so that the value can be returned. */
- if (parmse.string_length && fsym && fsym->ts.deferred)
- {
- if (INDIRECT_REF_P (parmse.string_length))
- /* In chains of functions/procedure calls the string_length already
- is a pointer to the variable holding the length. Therefore
- remove the deref on call. */
- parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
- else
- {
- tmp = parmse.string_length;
- if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
- tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
- parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
- }
- }
-
- /* Character strings are passed as two parameters, a length and a
- pointer - except for Bind(c) which only passes the pointer.
- An unlimited polymorphic formal argument likewise does not
- need the length. */
- if (parmse.string_length != NULL_TREE
- && !sym->attr.is_bind_c
- && !(fsym && UNLIMITED_POLY (fsym)))
- vec_safe_push (stringargs, parmse.string_length);
-
- /* When calling __copy for character expressions to unlimited
- polymorphic entities, the dst argument needs a string length. */
- if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
- && startswith (sym->name, "__vtab_CHARACTER")
- && arg->next && arg->next->expr
- && (arg->next->expr->ts.type == BT_DERIVED
- || arg->next->expr->ts.type == BT_CLASS)
- && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
- vec_safe_push (stringargs, parmse.string_length);
-
- /* For descriptorless coarrays and assumed-shape coarray dummies, we
- pass the token and the offset as additional arguments. */
- if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
- && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
- && !fsym->attr.allocatable)
- || (fsym->ts.type == BT_CLASS
- && CLASS_DATA (fsym)->attr.codimension
- && !CLASS_DATA (fsym)->attr.allocatable)))
- {
- /* Token and offset. */
- vec_safe_push (stringargs, null_pointer_node);
- vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
- gcc_assert (fsym->attr.optional);
- }
- else if (fsym && flag_coarray == GFC_FCOARRAY_LIB
- && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
- && !fsym->attr.allocatable)
- || (fsym->ts.type == BT_CLASS
- && CLASS_DATA (fsym)->attr.codimension
- && !CLASS_DATA (fsym)->attr.allocatable)))
- {
- tree caf_decl, caf_type;
- tree offset, tmp2;
-
- caf_decl = gfc_get_tree_for_caf_expr (e);
- caf_type = TREE_TYPE (caf_decl);
-
- if (GFC_DESCRIPTOR_TYPE_P (caf_type)
- && (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE
- || GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER))
- tmp = gfc_conv_descriptor_token (caf_decl);
- else if (DECL_LANG_SPECIFIC (caf_decl)
- && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
- tmp = GFC_DECL_TOKEN (caf_decl);
- else
- {
- gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
- && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
- tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
- }
-
- vec_safe_push (stringargs, tmp);
-
- if (GFC_DESCRIPTOR_TYPE_P (caf_type)
- && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
- offset = build_int_cst (gfc_array_index_type, 0);
- else if (DECL_LANG_SPECIFIC (caf_decl)
- && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
- offset = GFC_DECL_CAF_OFFSET (caf_decl);
- else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
- offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
- else
- offset = build_int_cst (gfc_array_index_type, 0);
-
- if (GFC_DESCRIPTOR_TYPE_P (caf_type))
- tmp = gfc_conv_descriptor_data_get (caf_decl);
- else
- {
- gcc_assert (POINTER_TYPE_P (caf_type));
- tmp = caf_decl;
- }
-
- tmp2 = fsym->ts.type == BT_CLASS
- ? gfc_class_data_get (parmse.expr) : parmse.expr;
- if ((fsym->ts.type != BT_CLASS
- && (fsym->as->type == AS_ASSUMED_SHAPE
- || fsym->as->type == AS_ASSUMED_RANK))
- || (fsym->ts.type == BT_CLASS
- && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
- || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
- {
- if (fsym->ts.type == BT_CLASS)
- gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
- else
- {
- gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
- tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
- }
- gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
- tmp2 = gfc_conv_descriptor_data_get (tmp2);
- }
- else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
- tmp2 = gfc_conv_descriptor_data_get (tmp2);
- else
- {
- gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
- }
-
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- fold_convert (gfc_array_index_type, tmp2),
- fold_convert (gfc_array_index_type, tmp));
- offset = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, offset, tmp);
-
- vec_safe_push (stringargs, offset);
- }
-
- vec_safe_push (arglist, parmse.expr);
- }
- gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
-
- if (comp)
- ts = comp->ts;
- else if (sym->ts.type == BT_CLASS)
- ts = CLASS_DATA (sym)->ts;
- else
- ts = sym->ts;
-
- if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
- se->string_length = build_int_cst (gfc_charlen_type_node, 1);
- else if (ts.type == BT_CHARACTER)
- {
- if (ts.u.cl->length == NULL)
- {
- /* Assumed character length results are not allowed by C418 of the 2003
- standard and are trapped in resolve.c; except in the case of SPREAD
- (and other intrinsics?) and dummy functions. In the case of SPREAD,
- we take the character length of the first argument for the result.
- For dummies, we have to look through the formal argument list for
- this function and use the character length found there.*/
- if (ts.deferred)
- cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
- else if (!sym->attr.dummy)
- cl.backend_decl = (*stringargs)[0];
- else
- {
- formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
- for (; formal; formal = formal->next)
- if (strcmp (formal->sym->name, sym->name) == 0)
- cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
- }
- len = cl.backend_decl;
- }
- else
- {
- tree tmp;
-
- /* Calculate the length of the returned string. */
- gfc_init_se (&parmse, NULL);
- if (need_interface_mapping)
- gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
- else
- gfc_conv_expr (&parmse, ts.u.cl->length);
- gfc_add_block_to_block (&se->pre, &parmse.pre);
- gfc_add_block_to_block (&se->post, &parmse.post);
- tmp = parmse.expr;
- /* TODO: It would be better to have the charlens as
- gfc_charlen_type_node already when the interface is
- created instead of converting it here (see PR 84615). */
- tmp = fold_build2_loc (input_location, MAX_EXPR,
- gfc_charlen_type_node,
- fold_convert (gfc_charlen_type_node, tmp),
- build_zero_cst (gfc_charlen_type_node));
- cl.backend_decl = tmp;
- }
-
- /* Set up a charlen structure for it. */
- cl.next = NULL;
- cl.length = NULL;
- ts.u.cl = &cl;
-
- len = cl.backend_decl;
- }
-
- byref = (comp && (comp->attr.dimension
- || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
- || (!comp && gfc_return_by_reference (sym));
- if (byref)
- {
- if (se->direct_byref)
- {
- /* Sometimes, too much indirection can be applied; e.g. for
- function_result = array_valued_recursive_function. */
- if (TREE_TYPE (TREE_TYPE (se->expr))
- && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
- && GFC_DESCRIPTOR_TYPE_P
- (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
- se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
-
- /* If the lhs of an assignment x = f(..) is allocatable and
- f2003 is allowed, we must do the automatic reallocation.
- TODO - deal with intrinsics, without using a temporary. */
- if (flag_realloc_lhs
- && se->ss && se->ss->loop_chain
- && se->ss->loop_chain->is_alloc_lhs
- && !expr->value.function.isym
- && sym->result->as != NULL)
- {
- /* Evaluate the bounds of the result, if known. */
- gfc_set_loop_bounds_from_array_spec (&mapping, se,
- sym->result->as);
-
- /* Perform the automatic reallocation. */
- tmp = gfc_alloc_allocatable_for_assignment (se->loop,
- expr, NULL);
- gfc_add_expr_to_block (&se->pre, tmp);
-
- /* Pass the temporary as the first argument. */
- result = info->descriptor;
- }
- else
- result = build_fold_indirect_ref_loc (input_location,
- se->expr);
- vec_safe_push (retargs, se->expr);
- }
- else if (comp && comp->attr.dimension)
- {
- gcc_assert (se->loop && info);
-
- /* Set the type of the array. */
- tmp = gfc_typenode_for_spec (&comp->ts);
- gcc_assert (se->ss->dimen == se->loop->dimen);
-
- /* Evaluate the bounds of the result, if known. */
- gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
-
- /* If the lhs of an assignment x = f(..) is allocatable and
- f2003 is allowed, we must not generate the function call
- here but should just send back the results of the mapping.
- This is signalled by the function ss being flagged. */
- if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
- {
- gfc_free_interface_mapping (&mapping);
- return has_alternate_specifier;
- }
-
- /* Create a temporary to store the result. In case the function
- returns a pointer, the temporary will be a shallow copy and
- mustn't be deallocated. */
- callee_alloc = comp->attr.allocatable || comp->attr.pointer;
- gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
- tmp, NULL_TREE, false,
- !comp->attr.pointer, callee_alloc,
- &se->ss->info->expr->where);
-
- /* Pass the temporary as the first argument. */
- result = info->descriptor;
- tmp = gfc_build_addr_expr (NULL_TREE, result);
- vec_safe_push (retargs, tmp);
- }
- else if (!comp && sym->result->attr.dimension)
- {
- gcc_assert (se->loop && info);
-
- /* Set the type of the array. */
- tmp = gfc_typenode_for_spec (&ts);
- gcc_assert (se->ss->dimen == se->loop->dimen);
-
- /* Evaluate the bounds of the result, if known. */
- gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
-
- /* If the lhs of an assignment x = f(..) is allocatable and
- f2003 is allowed, we must not generate the function call
- here but should just send back the results of the mapping.
- This is signalled by the function ss being flagged. */
- if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
- {
- gfc_free_interface_mapping (&mapping);
- return has_alternate_specifier;
- }
-
- /* Create a temporary to store the result. In case the function
- returns a pointer, the temporary will be a shallow copy and
- mustn't be deallocated. */
- callee_alloc = sym->attr.allocatable || sym->attr.pointer;
- gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
- tmp, NULL_TREE, false,
- !sym->attr.pointer, callee_alloc,
- &se->ss->info->expr->where);
-
- /* Pass the temporary as the first argument. */
- result = info->descriptor;
- tmp = gfc_build_addr_expr (NULL_TREE, result);
- vec_safe_push (retargs, tmp);
- }
- else if (ts.type == BT_CHARACTER)
- {
- /* Pass the string length. */
- type = gfc_get_character_type (ts.kind, ts.u.cl);
- type = build_pointer_type (type);
-
- /* Emit a DECL_EXPR for the VLA type. */
- tmp = TREE_TYPE (type);
- if (TYPE_SIZE (tmp)
- && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
- {
- tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
- DECL_ARTIFICIAL (tmp) = 1;
- DECL_IGNORED_P (tmp) = 1;
- tmp = fold_build1_loc (input_location, DECL_EXPR,
- TREE_TYPE (tmp), tmp);
- gfc_add_expr_to_block (&se->pre, tmp);
- }
-
- /* Return an address to a char[0:len-1]* temporary for
- character pointers. */
- if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
- || (comp && (comp->attr.pointer || comp->attr.allocatable)))
- {
- var = gfc_create_var (type, "pstr");
-
- if ((!comp && sym->attr.allocatable)
- || (comp && comp->attr.allocatable))
- {
- gfc_add_modify (&se->pre, var,
- fold_convert (TREE_TYPE (var),
- null_pointer_node));
- tmp = gfc_call_free (var);
- gfc_add_expr_to_block (&se->post, tmp);
- }
-
- /* Provide an address expression for the function arguments. */
- var = gfc_build_addr_expr (NULL_TREE, var);
- }
- else
- var = gfc_conv_string_tmp (se, type, len);
-
- vec_safe_push (retargs, var);
- }
- else
- {
- gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
-
- type = gfc_get_complex_type (ts.kind);
- var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
- vec_safe_push (retargs, var);
- }
-
- /* Add the string length to the argument list. */
- if (ts.type == BT_CHARACTER && ts.deferred)
- {
- tmp = len;
- if (!VAR_P (tmp))
- tmp = gfc_evaluate_now (len, &se->pre);
- TREE_STATIC (tmp) = 1;
- gfc_add_modify (&se->pre, tmp,
- build_int_cst (TREE_TYPE (tmp), 0));
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
- vec_safe_push (retargs, tmp);
- }
- else if (ts.type == BT_CHARACTER)
- vec_safe_push (retargs, len);
- }
- gfc_free_interface_mapping (&mapping);
-
- /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
- arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
- + vec_safe_length (stringargs) + vec_safe_length (append_args));
- vec_safe_reserve (retargs, arglen);
-
- /* Add the return arguments. */
- vec_safe_splice (retargs, arglist);
-
- /* Add the hidden present status for optional+value to the arguments. */
- vec_safe_splice (retargs, optionalargs);
-
- /* Add the hidden string length parameters to the arguments. */
- vec_safe_splice (retargs, stringargs);
-
- /* We may want to append extra arguments here. This is used e.g. for
- calls to libgfortran_matmul_??, which need extra information. */
- vec_safe_splice (retargs, append_args);
-
- arglist = retargs;
-
- /* Generate the actual call. */
- if (base_object == NULL_TREE)
- conv_function_val (se, sym, expr, args);
- else
- conv_base_obj_fcn_val (se, base_object, expr);
-
- /* If there are alternate return labels, function type should be
- integer. Can't modify the type in place though, since it can be shared
- with other functions. For dummy arguments, the typing is done to
- this result, even if it has to be repeated for each call. */
- if (has_alternate_specifier
- && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
- {
- if (!sym->attr.dummy)
- {
- TREE_TYPE (sym->backend_decl)
- = build_function_type (integer_type_node,
- TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
- se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
- }
- else
- TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
- }
-
- fntype = TREE_TYPE (TREE_TYPE (se->expr));
- se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
-
- /* Allocatable scalar function results must be freed and nullified
- after use. This necessitates the creation of a temporary to
- hold the result to prevent duplicate calls. */
- if (!byref && sym->ts.type != BT_CHARACTER
- && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
- || (comp && comp->attr.allocatable && !comp->attr.dimension)))
- {
- tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
- gfc_add_modify (&se->pre, tmp, se->expr);
- se->expr = tmp;
- tmp = gfc_call_free (tmp);
- gfc_add_expr_to_block (&post, tmp);
- gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
- }
-
- /* If we have a pointer function, but we don't want a pointer, e.g.
- something like
- x = f()
- where f is pointer valued, we have to dereference the result. */
- if (!se->want_pointer && !byref
- && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
- || (comp && (comp->attr.pointer || comp->attr.allocatable))))
- se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
-
- /* f2c calling conventions require a scalar default real function to
- return a double precision result. Convert this back to default
- real. We only care about the cases that can happen in Fortran 77.
- */
- if (flag_f2c && sym->ts.type == BT_REAL
- && sym->ts.kind == gfc_default_real_kind
- && !sym->attr.always_explicit)
- se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
-
- /* A pure function may still have side-effects - it may modify its
- parameters. */
- TREE_SIDE_EFFECTS (se->expr) = 1;
-#if 0
- if (!sym->attr.pure)
- TREE_SIDE_EFFECTS (se->expr) = 1;
-#endif
-
- if (byref)
- {
- /* Add the function call to the pre chain. There is no expression. */
- gfc_add_expr_to_block (&se->pre, se->expr);
- se->expr = NULL_TREE;
-
- if (!se->direct_byref)
- {
- if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
- {
- if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
- {
- /* Check the data pointer hasn't been modified. This would
- happen in a function returning a pointer. */
- tmp = gfc_conv_descriptor_data_get (info->descriptor);
- tmp = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node,
- tmp, info->data);
- gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
- gfc_msg_fault);
- }
- se->expr = info->descriptor;
- /* Bundle in the string length. */
- se->string_length = len;
- }
- else if (ts.type == BT_CHARACTER)
- {
- /* Dereference for character pointer results. */
- if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
- || (comp && (comp->attr.pointer || comp->attr.allocatable)))
- se->expr = build_fold_indirect_ref_loc (input_location, var);
- else
- se->expr = var;
-
- se->string_length = len;
- }
- else
- {
- gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
- se->expr = build_fold_indirect_ref_loc (input_location, var);
- }
- }
- }
-
- /* Associate the rhs class object's meta-data with the result, when the
- result is a temporary. */
- if (args && args->expr && args->expr->ts.type == BT_CLASS
- && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
- && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
- {
- gfc_se parmse;
- gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
-
- gfc_init_se (&parmse, NULL);
- parmse.data_not_needed = 1;
- gfc_conv_expr (&parmse, class_expr);
- if (!DECL_LANG_SPECIFIC (result))
- gfc_allocate_lang_decl (result);
- GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
- gfc_free_expr (class_expr);
- /* -fcheck= can add diagnostic code, which has to be placed before
- the call. */
- if (parmse.pre.head != NULL)
- gfc_add_expr_to_block (&se->pre, parmse.pre.head);
- gcc_assert (parmse.post.head == NULL_TREE);
- }
-
- /* Follow the function call with the argument post block. */
- if (byref)
- {
- gfc_add_block_to_block (&se->pre, &post);
-
- /* Transformational functions of derived types with allocatable
- components must have the result allocatable components copied when the
- argument is actually given. */
- arg = expr->value.function.actual;
- if (result && arg && expr->rank
- && expr->value.function.isym
- && expr->value.function.isym->transformational
- && arg->expr
- && arg->expr->ts.type == BT_DERIVED
- && arg->expr->ts.u.derived->attr.alloc_comp)
- {
- tree tmp2;
- /* Copy the allocatable components. We have to use a
- temporary here to prevent source allocatable components
- from being corrupted. */
- tmp2 = gfc_evaluate_now (result, &se->pre);
- tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
- result, tmp2, expr->rank, 0);
- gfc_add_expr_to_block (&se->pre, tmp);
- tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
- expr->rank);
- gfc_add_expr_to_block (&se->pre, tmp);
-
- /* Finally free the temporary's data field. */
- tmp = gfc_conv_descriptor_data_get (tmp2);
- tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
- NULL_TREE, NULL_TREE, true,
- NULL, GFC_CAF_COARRAY_NOCOARRAY);
- gfc_add_expr_to_block (&se->pre, tmp);
- }
- }
- else
- {
- /* For a function with a class array result, save the result as
- a temporary, set the info fields needed by the scalarizer and
- call the finalization function of the temporary. Note that the
- nullification of allocatable components needed by the result
- is done in gfc_trans_assignment_1. */
- if (expr && ((gfc_is_class_array_function (expr)
- && se->ss && se->ss->loop)
- || gfc_is_alloc_class_scalar_function (expr))
- && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
- && expr->must_finalize)
- {
- tree final_fndecl;
- tree is_final;
- int n;
- if (se->ss && se->ss->loop)
- {
- gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
- se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
- tmp = gfc_class_data_get (se->expr);
- info->descriptor = tmp;
- info->data = gfc_conv_descriptor_data_get (tmp);
- info->offset = gfc_conv_descriptor_offset_get (tmp);
- for (n = 0; n < se->ss->loop->dimen; n++)
- {
- tree dim = gfc_rank_cst[n];
- se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim);
- se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim);
- }
- }
- else
- {
- /* TODO Eliminate the doubling of temporaries. This
- one is necessary to ensure no memory leakage. */
- se->expr = gfc_evaluate_now (se->expr, &se->pre);
- tmp = gfc_class_data_get (se->expr);
- tmp = gfc_conv_scalar_to_descriptor (se, tmp,
- CLASS_DATA (expr->value.function.esym->result)->attr);
- }
-
- if ((gfc_is_class_array_function (expr)
- || gfc_is_alloc_class_scalar_function (expr))
- && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
- goto no_finalization;
-
- final_fndecl = gfc_class_vtab_final_get (se->expr);
- is_final = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node,
- final_fndecl,
- fold_convert (TREE_TYPE (final_fndecl),
- null_pointer_node));
- final_fndecl = build_fold_indirect_ref_loc (input_location,
- final_fndecl);
- tmp = build_call_expr_loc (input_location,
- final_fndecl, 3,
- gfc_build_addr_expr (NULL, tmp),
- gfc_class_vtab_size_get (se->expr),
- boolean_false_node);
- tmp = fold_build3_loc (input_location, COND_EXPR,
- void_type_node, is_final, tmp,
- build_empty_stmt (input_location));
-
- if (se->ss && se->ss->loop)
- {
- gfc_prepend_expr_to_block (&se->ss->loop->post, tmp);
- tmp = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node,
- info->data,
- fold_convert (TREE_TYPE (info->data),
- null_pointer_node));
- tmp = fold_build3_loc (input_location, COND_EXPR,
- void_type_node, tmp,
- gfc_call_free (info->data),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&se->ss->loop->post, tmp);
- }
- else
- {
- tree classdata;
- gfc_prepend_expr_to_block (&se->post, tmp);
- classdata = gfc_class_data_get (se->expr);
- tmp = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node,
- classdata,
- fold_convert (TREE_TYPE (classdata),
- null_pointer_node));
- tmp = fold_build3_loc (input_location, COND_EXPR,
- void_type_node, tmp,
- gfc_call_free (classdata),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&se->post, tmp);
- }
- }
-
-no_finalization:
- gfc_add_block_to_block (&se->post, &post);
- }
-
- return has_alternate_specifier;
-}
-
-
-/* Fill a character string with spaces. */
-
-static tree
-fill_with_spaces (tree start, tree type, tree size)
-{
- stmtblock_t block, loop;
- tree i, el, exit_label, cond, tmp;
-
- /* For a simple char type, we can call memset(). */
- if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
- return build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_MEMSET),
- 3, start,
- build_int_cst (gfc_get_int_type (gfc_c_int_kind),
- lang_hooks.to_target_charset (' ')),
- fold_convert (size_type_node, size));
-
- /* Otherwise, we use a loop:
- for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
- *el = (type) ' ';
- */
-
- /* Initialize variables. */
- gfc_init_block (&block);
- i = gfc_create_var (sizetype, "i");
- gfc_add_modify (&block, i, fold_convert (sizetype, size));
- el = gfc_create_var (build_pointer_type (type), "el");
- gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
- exit_label = gfc_build_label_decl (NULL_TREE);
- TREE_USED (exit_label) = 1;
-
-
- /* Loop body. */
- gfc_init_block (&loop);
-
- /* Exit condition. */
- cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
- build_zero_cst (sizetype));
- tmp = build1_v (GOTO_EXPR, exit_label);
- tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&loop, tmp);
-
- /* Assignment. */
- gfc_add_modify (&loop,
- fold_build1_loc (input_location, INDIRECT_REF, type, el),
- build_int_cst (type, lang_hooks.to_target_charset (' ')));
-
- /* Increment loop variables. */
- gfc_add_modify (&loop, i,
- fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
- TYPE_SIZE_UNIT (type)));
- gfc_add_modify (&loop, el,
- fold_build_pointer_plus_loc (input_location,
- el, TYPE_SIZE_UNIT (type)));
-
- /* Making the loop... actually loop! */
- tmp = gfc_finish_block (&loop);
- tmp = build1_v (LOOP_EXPR, tmp);
- gfc_add_expr_to_block (&block, tmp);
-
- /* The exit label. */
- tmp = build1_v (LABEL_EXPR, exit_label);
- gfc_add_expr_to_block (&block, tmp);
-
-
- return gfc_finish_block (&block);
-}
-
-
-/* Generate code to copy a string. */
-
-void
-gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
- int dkind, tree slength, tree src, int skind)
-{
- tree tmp, dlen, slen;
- tree dsc;
- tree ssc;
- tree cond;
- tree cond2;
- tree tmp2;
- tree tmp3;
- tree tmp4;
- tree chartype;
- stmtblock_t tempblock;
-
- gcc_assert (dkind == skind);
-
- if (slength != NULL_TREE)
- {
- slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
- ssc = gfc_string_to_single_character (slen, src, skind);
- }
- else
- {
- slen = build_one_cst (gfc_charlen_type_node);
- ssc = src;
- }
-
- if (dlength != NULL_TREE)
- {
- dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
- dsc = gfc_string_to_single_character (dlen, dest, dkind);
- }
- else
- {
- dlen = build_one_cst (gfc_charlen_type_node);
- dsc = dest;
- }
-
- /* Assign directly if the types are compatible. */
- if (dsc != NULL_TREE && ssc != NULL_TREE
- && TREE_TYPE (dsc) == TREE_TYPE (ssc))
- {
- gfc_add_modify (block, dsc, ssc);
- return;
- }
-
- /* The string copy algorithm below generates code like
-
- if (destlen > 0)
- {
- if (srclen < destlen)
- {
- memmove (dest, src, srclen);
- // Pad with spaces.
- memset (&dest[srclen], ' ', destlen - srclen);
- }
- else
- {
- // Truncate if too long.
- memmove (dest, src, destlen);
- }
- }
- */
-
- /* Do nothing if the destination length is zero. */
- cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
- build_zero_cst (TREE_TYPE (dlen)));
-
- /* For non-default character kinds, we have to multiply the string
- length by the base type size. */
- chartype = gfc_get_char_type (dkind);
- slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
- slen,
- fold_convert (TREE_TYPE (slen),
- TYPE_SIZE_UNIT (chartype)));
- dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
- dlen,
- fold_convert (TREE_TYPE (dlen),
- TYPE_SIZE_UNIT (chartype)));
-
- if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
- dest = fold_convert (pvoid_type_node, dest);
- else
- dest = gfc_build_addr_expr (pvoid_type_node, dest);
-
- if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
- src = fold_convert (pvoid_type_node, src);
- else
- src = gfc_build_addr_expr (pvoid_type_node, src);
-
- /* Truncate string if source is too long. */
- cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
- dlen);
-
- /* Copy and pad with spaces. */
- tmp3 = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_MEMMOVE),
- 3, dest, src,
- fold_convert (size_type_node, slen));
-
- /* Wstringop-overflow appears at -O3 even though this warning is not
- explicitly available in fortran nor can it be switched off. If the
- source length is a constant, its negative appears as a very large
- postive number and triggers the warning in BUILTIN_MEMSET. Fixing
- the result of the MINUS_EXPR suppresses this spurious warning. */
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- TREE_TYPE(dlen), dlen, slen);
- if (slength && TREE_CONSTANT (slength))
- tmp = gfc_evaluate_now (tmp, block);
-
- tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
- tmp4 = fill_with_spaces (tmp4, chartype, tmp);
-
- gfc_init_block (&tempblock);
- gfc_add_expr_to_block (&tempblock, tmp3);
- gfc_add_expr_to_block (&tempblock, tmp4);
- tmp3 = gfc_finish_block (&tempblock);
-
- /* The truncated memmove if the slen >= dlen. */
- tmp2 = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_MEMMOVE),
- 3, dest, src,
- fold_convert (size_type_node, dlen));
-
- /* The whole copy_string function is there. */
- tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
- tmp3, tmp2);
- tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (block, tmp);
-}
-
-
-/* Translate a statement function.
- The value of a statement function reference is obtained by evaluating the
- expression using the values of the actual arguments for the values of the
- corresponding dummy arguments. */
-
-static void
-gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
-{
- gfc_symbol *sym;
- gfc_symbol *fsym;
- gfc_formal_arglist *fargs;
- gfc_actual_arglist *args;
- gfc_se lse;
- gfc_se rse;
- gfc_saved_var *saved_vars;
- tree *temp_vars;
- tree type;
- tree tmp;
- int n;
-
- sym = expr->symtree->n.sym;
- args = expr->value.function.actual;
- gfc_init_se (&lse, NULL);
- gfc_init_se (&rse, NULL);
-
- n = 0;
- for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
- n++;
- saved_vars = XCNEWVEC (gfc_saved_var, n);
- temp_vars = XCNEWVEC (tree, n);
-
- for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
- fargs = fargs->next, n++)
- {
- /* Each dummy shall be specified, explicitly or implicitly, to be
- scalar. */
- gcc_assert (fargs->sym->attr.dimension == 0);
- fsym = fargs->sym;
-
- if (fsym->ts.type == BT_CHARACTER)
- {
- /* Copy string arguments. */
- tree arglen;
-
- gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
- && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
-
- /* Create a temporary to hold the value. */
- if (fsym->ts.u.cl->backend_decl == NULL_TREE)
- fsym->ts.u.cl->backend_decl
- = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
-
- type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
- temp_vars[n] = gfc_create_var (type, fsym->name);
-
- arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
-
- gfc_conv_expr (&rse, args->expr);
- gfc_conv_string_parameter (&rse);
- gfc_add_block_to_block (&se->pre, &lse.pre);
- gfc_add_block_to_block (&se->pre, &rse.pre);
-
- gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
- rse.string_length, rse.expr, fsym->ts.kind);
- gfc_add_block_to_block (&se->pre, &lse.post);
- gfc_add_block_to_block (&se->pre, &rse.post);
- }
- else
- {
- /* For everything else, just evaluate the expression. */
-
- /* Create a temporary to hold the value. */
- type = gfc_typenode_for_spec (&fsym->ts);
- temp_vars[n] = gfc_create_var (type, fsym->name);
-
- gfc_conv_expr (&lse, args->expr);
-
- gfc_add_block_to_block (&se->pre, &lse.pre);
- gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
- gfc_add_block_to_block (&se->pre, &lse.post);
- }
-
- args = args->next;
- }
-
- /* Use the temporary variables in place of the real ones. */
- for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
- fargs = fargs->next, n++)
- gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
-
- gfc_conv_expr (se, sym->value);
-
- if (sym->ts.type == BT_CHARACTER)
- {
- gfc_conv_const_charlen (sym->ts.u.cl);
-
- /* Force the expression to the correct length. */
- if (!INTEGER_CST_P (se->string_length)
- || tree_int_cst_lt (se->string_length,
- sym->ts.u.cl->backend_decl))
- {
- type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
- tmp = gfc_create_var (type, sym->name);
- tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
- gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
- sym->ts.kind, se->string_length, se->expr,
- sym->ts.kind);
- se->expr = tmp;
- }
- se->string_length = sym->ts.u.cl->backend_decl;
- }
-
- /* Restore the original variables. */
- for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
- fargs = fargs->next, n++)
- gfc_restore_sym (fargs->sym, &saved_vars[n]);
- free (temp_vars);
- free (saved_vars);
-}
-
-
-/* Translate a function expression. */
-
-static void
-gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
-{
- gfc_symbol *sym;
-
- if (expr->value.function.isym)
- {
- gfc_conv_intrinsic_function (se, expr);
- return;
- }
-
- /* expr.value.function.esym is the resolved (specific) function symbol for
- most functions. However this isn't set for dummy procedures. */
- sym = expr->value.function.esym;
- if (!sym)
- sym = expr->symtree->n.sym;
-
- /* The IEEE_ARITHMETIC functions are caught here. */
- if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
- if (gfc_conv_ieee_arithmetic_function (se, expr))
- return;
-
- /* We distinguish statement functions from general functions to improve
- runtime performance. */
- if (sym->attr.proc == PROC_ST_FUNCTION)
- {
- gfc_conv_statement_function (se, expr);
- return;
- }
-
- gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
- NULL);
-}
-
-
-/* Determine whether the given EXPR_CONSTANT is a zero initializer. */
-
-static bool
-is_zero_initializer_p (gfc_expr * expr)
-{
- if (expr->expr_type != EXPR_CONSTANT)
- return false;
-
- /* We ignore constants with prescribed memory representations for now. */
- if (expr->representation.string)
- return false;
-
- switch (expr->ts.type)
- {
- case BT_INTEGER:
- return mpz_cmp_si (expr->value.integer, 0) == 0;
-
- case BT_REAL:
- return mpfr_zero_p (expr->value.real)
- && MPFR_SIGN (expr->value.real) >= 0;
-
- case BT_LOGICAL:
- return expr->value.logical == 0;
-
- case BT_COMPLEX:
- return mpfr_zero_p (mpc_realref (expr->value.complex))
- && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
- && mpfr_zero_p (mpc_imagref (expr->value.complex))
- && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
-
- default:
- break;
- }
- return false;
-}
-
-
-static void
-gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
-{
- gfc_ss *ss;
-
- ss = se->ss;
- gcc_assert (ss != NULL && ss != gfc_ss_terminator);
- gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
-
- gfc_conv_tmp_array_ref (se);
-}
-
-
-/* Build a static initializer. EXPR is the expression for the initial value.
- The other parameters describe the variable of the component being
- initialized. EXPR may be null. */
-
-tree
-gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
- bool array, bool pointer, bool procptr)
-{
- gfc_se se;
-
- if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
- && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
- && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
- return build_constructor (type, NULL);
-
- if (!(expr || pointer || procptr))
- return NULL_TREE;
-
- /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
- (these are the only two iso_c_binding derived types that can be
- used as initialization expressions). If so, we need to modify
- the 'expr' to be that for a (void *). */
- if (expr != NULL && expr->ts.type == BT_DERIVED
- && expr->ts.is_iso_c && expr->ts.u.derived)
- {
- if (TREE_CODE (type) == ARRAY_TYPE)
- return build_constructor (type, NULL);
- else if (POINTER_TYPE_P (type))
- return build_int_cst (type, 0);
- else
- gcc_unreachable ();
- }
-
- if (array && !procptr)
- {
- tree ctor;
- /* Arrays need special handling. */
- if (pointer)
- ctor = gfc_build_null_descriptor (type);
- /* Special case assigning an array to zero. */
- else if (is_zero_initializer_p (expr))
- ctor = build_constructor (type, NULL);
- else
- ctor = gfc_conv_array_initializer (type, expr);
- TREE_STATIC (ctor) = 1;
- return ctor;
- }
- else if (pointer || procptr)
- {
- if (ts->type == BT_CLASS && !procptr)
- {
- gfc_init_se (&se, NULL);
- gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
- gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
- TREE_STATIC (se.expr) = 1;
- return se.expr;
- }
- else if (!expr || expr->expr_type == EXPR_NULL)
- return fold_convert (type, null_pointer_node);
- else
- {
- gfc_init_se (&se, NULL);
- se.want_pointer = 1;
- gfc_conv_expr (&se, expr);
- gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
- return se.expr;
- }
- }
- else
- {
- switch (ts->type)
- {
- case_bt_struct:
- case BT_CLASS:
- gfc_init_se (&se, NULL);
- if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
- gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
- else
- gfc_conv_structure (&se, expr, 1);
- gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
- TREE_STATIC (se.expr) = 1;
- return se.expr;
-
- case BT_CHARACTER:
- if (expr->expr_type == EXPR_CONSTANT)
- {
- tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl, expr);
- TREE_STATIC (ctor) = 1;
- return ctor;
- }
-
- /* Fallthrough. */
- default:
- gfc_init_se (&se, NULL);
- gfc_conv_constant (&se, expr);
- gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
- return se.expr;
- }
- }
-}
-
-static tree
-gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
-{
- gfc_se rse;
- gfc_se lse;
- gfc_ss *rss;
- gfc_ss *lss;
- gfc_array_info *lss_array;
- stmtblock_t body;
- stmtblock_t block;
- gfc_loopinfo loop;
- int n;
- tree tmp;
-
- gfc_start_block (&block);
-
- /* Initialize the scalarizer. */
- gfc_init_loopinfo (&loop);
-
- gfc_init_se (&lse, NULL);
- gfc_init_se (&rse, NULL);
-
- /* Walk the rhs. */
- rss = gfc_walk_expr (expr);
- if (rss == gfc_ss_terminator)
- /* The rhs is scalar. Add a ss for the expression. */
- rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
-
- /* Create a SS for the destination. */
- lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
- GFC_SS_COMPONENT);
- lss_array = &lss->info->data.array;
- lss_array->shape = gfc_get_shape (cm->as->rank);
- lss_array->descriptor = dest;
- lss_array->data = gfc_conv_array_data (dest);
- lss_array->offset = gfc_conv_array_offset (dest);
- for (n = 0; n < cm->as->rank; n++)
- {
- lss_array->start[n] = gfc_conv_array_lbound (dest, n);
- lss_array->stride[n] = gfc_index_one_node;
-
- mpz_init (lss_array->shape[n]);
- mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
- cm->as->lower[n]->value.integer);
- mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
- }
-
- /* Associate the SS with the loop. */
- gfc_add_ss_to_loop (&loop, lss);
- gfc_add_ss_to_loop (&loop, rss);
-
- /* Calculate the bounds of the scalarization. */
- gfc_conv_ss_startstride (&loop);
-
- /* Setup the scalarizing loops. */
- gfc_conv_loop_setup (&loop, &expr->where);
-
- /* Setup the gfc_se structures. */
- gfc_copy_loopinfo_to_se (&lse, &loop);
- gfc_copy_loopinfo_to_se (&rse, &loop);
-
- rse.ss = rss;
- gfc_mark_ss_chain_used (rss, 1);
- lse.ss = lss;
- gfc_mark_ss_chain_used (lss, 1);
-
- /* Start the scalarized loop body. */
- gfc_start_scalarized_body (&loop, &body);
-
- gfc_conv_tmp_array_ref (&lse);
- if (cm->ts.type == BT_CHARACTER)
- lse.string_length = cm->ts.u.cl->backend_decl;
-
- gfc_conv_expr (&rse, expr);
-
- tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
- gfc_add_expr_to_block (&body, tmp);
-
- gcc_assert (rse.ss == gfc_ss_terminator);
-
- /* Generate the copying loops. */
- gfc_trans_scalarizing_loops (&loop, &body);
-
- /* Wrap the whole thing up. */
- gfc_add_block_to_block (&block, &loop.pre);
- gfc_add_block_to_block (&block, &loop.post);
-
- gcc_assert (lss_array->shape != NULL);
- gfc_free_shape (&lss_array->shape, cm->as->rank);
- gfc_cleanup_loop (&loop);
-
- return gfc_finish_block (&block);
-}
-
-
-static tree
-gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
- gfc_expr * expr)
-{
- gfc_se se;
- stmtblock_t block;
- tree offset;
- int n;
- tree tmp;
- tree tmp2;
- gfc_array_spec *as;
- gfc_expr *arg = NULL;
-
- gfc_start_block (&block);
- gfc_init_se (&se, NULL);
-
- /* Get the descriptor for the expressions. */
- se.want_pointer = 0;
- gfc_conv_expr_descriptor (&se, expr);
- gfc_add_block_to_block (&block, &se.pre);
- gfc_add_modify (&block, dest, se.expr);
-
- /* Deal with arrays of derived types with allocatable components. */
- if (gfc_bt_struct (cm->ts.type)
- && cm->ts.u.derived->attr.alloc_comp)
- // TODO: Fix caf_mode
- tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
- se.expr, dest,
- cm->as->rank, 0);
- else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
- && CLASS_DATA(cm)->attr.allocatable)
- {
- if (cm->ts.u.derived->attr.alloc_comp)
- // TODO: Fix caf_mode
- tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
- se.expr, dest,
- expr->rank, 0);
- else
- {
- tmp = TREE_TYPE (dest);
- tmp = gfc_duplicate_allocatable (dest, se.expr,
- tmp, expr->rank, NULL_TREE);
- }
- }
- else
- tmp = gfc_duplicate_allocatable (dest, se.expr,
- TREE_TYPE(cm->backend_decl),
- cm->as->rank, NULL_TREE);
-
- gfc_add_expr_to_block (&block, tmp);
- gfc_add_block_to_block (&block, &se.post);
-
- if (expr->expr_type != EXPR_VARIABLE)
- gfc_conv_descriptor_data_set (&block, se.expr,
- null_pointer_node);
-
- /* We need to know if the argument of a conversion function is a
- variable, so that the correct lower bound can be used. */
- if (expr->expr_type == EXPR_FUNCTION
- && expr->value.function.isym
- && expr->value.function.isym->conversion
- && expr->value.function.actual->expr
- && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
- arg = expr->value.function.actual->expr;
-
- /* Obtain the array spec of full array references. */
- if (arg)
- as = gfc_get_full_arrayspec_from_expr (arg);
- else
- as = gfc_get_full_arrayspec_from_expr (expr);
-
- /* Shift the lbound and ubound of temporaries to being unity,
- rather than zero, based. Always calculate the offset. */
- offset = gfc_conv_descriptor_offset_get (dest);
- gfc_add_modify (&block, offset, gfc_index_zero_node);
- tmp2 =gfc_create_var (gfc_array_index_type, NULL);
-
- for (n = 0; n < expr->rank; n++)
- {
- tree span;
- tree lbound;
-
- /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
- TODO It looks as if gfc_conv_expr_descriptor should return
- the correct bounds and that the following should not be
- necessary. This would simplify gfc_conv_intrinsic_bound
- as well. */
- if (as && as->lower[n])
- {
- gfc_se lbse;
- gfc_init_se (&lbse, NULL);
- gfc_conv_expr (&lbse, as->lower[n]);
- gfc_add_block_to_block (&block, &lbse.pre);
- lbound = gfc_evaluate_now (lbse.expr, &block);
- }
- else if (as && arg)
- {
- tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
- lbound = gfc_conv_descriptor_lbound_get (tmp,
- gfc_rank_cst[n]);
- }
- else if (as)
- lbound = gfc_conv_descriptor_lbound_get (dest,
- gfc_rank_cst[n]);
- else
- lbound = gfc_index_one_node;
-
- lbound = fold_convert (gfc_array_index_type, lbound);
-
- /* Shift the bounds and set the offset accordingly. */
- tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
- span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
- tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- span, lbound);
- gfc_conv_descriptor_ubound_set (&block, dest,
- gfc_rank_cst[n], tmp);
- gfc_conv_descriptor_lbound_set (&block, dest,
- gfc_rank_cst[n], lbound);
-
- tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_lbound_get (dest,
- gfc_rank_cst[n]),
- gfc_conv_descriptor_stride_get (dest,
- gfc_rank_cst[n]));
- gfc_add_modify (&block, tmp2, tmp);
- tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- offset, tmp2);
- gfc_conv_descriptor_offset_set (&block, dest, tmp);
- }
-
- if (arg)
- {
- /* If a conversion expression has a null data pointer
- argument, nullify the allocatable component. */
- tree non_null_expr;
- tree null_expr;
-
- if (arg->symtree->n.sym->attr.allocatable
- || arg->symtree->n.sym->attr.pointer)
- {
- non_null_expr = gfc_finish_block (&block);
- gfc_start_block (&block);
- gfc_conv_descriptor_data_set (&block, dest,
- null_pointer_node);
- null_expr = gfc_finish_block (&block);
- tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
- tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
- fold_convert (TREE_TYPE (tmp), null_pointer_node));
- return build3_v (COND_EXPR, tmp,
- null_expr, non_null_expr);
- }
- }
-
- return gfc_finish_block (&block);
-}
-
-
-/* Allocate or reallocate scalar component, as necessary. */
-
-static void
-alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
- tree comp,
- gfc_component *cm,
- gfc_expr *expr2,
- gfc_symbol *sym)
-{
- tree tmp;
- tree ptr;
- tree size;
- tree size_in_bytes;
- tree lhs_cl_size = NULL_TREE;
-
- if (!comp)
- return;
-
- if (!expr2 || expr2->rank)
- return;
-
- realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
-
- if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
- {
- char name[GFC_MAX_SYMBOL_LEN+9];
- gfc_component *strlen;
- /* Use the rhs string length and the lhs element size. */
- gcc_assert (expr2->ts.type == BT_CHARACTER);
- if (!expr2->ts.u.cl->backend_decl)
- {
- gfc_conv_string_length (expr2->ts.u.cl, expr2, block);
- gcc_assert (expr2->ts.u.cl->backend_decl);
- }
-
- size = expr2->ts.u.cl->backend_decl;
-
- /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
- component. */
- sprintf (name, "_%s_length", cm->name);
- strlen = gfc_find_component (sym, name, true, true, NULL);
- lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
- gfc_charlen_type_node,
- TREE_OPERAND (comp, 0),
- strlen->backend_decl, NULL_TREE);
-
- tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
- tmp = TYPE_SIZE_UNIT (tmp);
- size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
- TREE_TYPE (tmp), tmp,
- fold_convert (TREE_TYPE (tmp), size));
- }
- else if (cm->ts.type == BT_CLASS)
- {
- gcc_assert (expr2->ts.type == BT_CLASS || expr2->ts.type == BT_DERIVED);
- if (expr2->ts.type == BT_DERIVED)
- {
- tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
- size = TYPE_SIZE_UNIT (tmp);
- }
- else
- {
- gfc_expr *e2vtab;
- gfc_se se;
- e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
- gfc_add_vptr_component (e2vtab);
- gfc_add_size_component (e2vtab);
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, e2vtab);
- gfc_add_block_to_block (block, &se.pre);
- size = fold_convert (size_type_node, se.expr);
- gfc_free_expr (e2vtab);
- }
- size_in_bytes = size;
- }
- else
- {
- /* Otherwise use the length in bytes of the rhs. */
- size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
- size_in_bytes = size;
- }
-
- size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
- size_in_bytes, size_one_node);
-
- if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
- {
- tmp = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_CALLOC),
- 2, build_one_cst (size_type_node),
- size_in_bytes);
- tmp = fold_convert (TREE_TYPE (comp), tmp);
- gfc_add_modify (block, comp, tmp);
- }
- else
- {
- tmp = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_MALLOC),
- 1, size_in_bytes);
- if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
- ptr = gfc_class_data_get (comp);
- else
- ptr = comp;
- tmp = fold_convert (TREE_TYPE (ptr), tmp);
- gfc_add_modify (block, ptr, tmp);
- }
-
- if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
- /* Update the lhs character length. */
- gfc_add_modify (block, lhs_cl_size,
- fold_convert (TREE_TYPE (lhs_cl_size), size));
-}
-
-
-/* Assign a single component of a derived type constructor. */
-
-static tree
-gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
- gfc_symbol *sym, bool init)
-{
- gfc_se se;
- gfc_se lse;
- stmtblock_t block;
- tree tmp;
- tree vtab;
-
- gfc_start_block (&block);
-
- if (cm->attr.pointer || cm->attr.proc_pointer)
- {
- /* Only care about pointers here, not about allocatables. */
- gfc_init_se (&se, NULL);
- /* Pointer component. */
- if ((cm->attr.dimension || cm->attr.codimension)
- && !cm->attr.proc_pointer)
- {
- /* Array pointer. */
- if (expr->expr_type == EXPR_NULL)
- gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
- else
- {
- se.direct_byref = 1;
- se.expr = dest;
- gfc_conv_expr_descriptor (&se, expr);
- gfc_add_block_to_block (&block, &se.pre);
- gfc_add_block_to_block (&block, &se.post);
- }
- }
- else
- {
- /* Scalar pointers. */
- se.want_pointer = 1;
- gfc_conv_expr (&se, expr);
- gfc_add_block_to_block (&block, &se.pre);
-
- if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
- && expr->symtree->n.sym->attr.dummy)
- se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
-
- gfc_add_modify (&block, dest,
- fold_convert (TREE_TYPE (dest), se.expr));
- gfc_add_block_to_block (&block, &se.post);
- }
- }
- else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
- {
- /* NULL initialization for CLASS components. */
- tmp = gfc_trans_structure_assign (dest,
- gfc_class_initializer (&cm->ts, expr),
- false);
- gfc_add_expr_to_block (&block, tmp);
- }
- else if ((cm->attr.dimension || cm->attr.codimension)
- && !cm->attr.proc_pointer)
- {
- if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
- gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
- else if (cm->attr.allocatable || cm->attr.pdt_array)
- {
- tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
- gfc_add_expr_to_block (&block, tmp);
- }
- else
- {
- tmp = gfc_trans_subarray_assign (dest, cm, expr);
- gfc_add_expr_to_block (&block, tmp);
- }
- }
- else if (cm->ts.type == BT_CLASS
- && CLASS_DATA (cm)->attr.dimension
- && CLASS_DATA (cm)->attr.allocatable
- && expr->ts.type == BT_DERIVED)
- {
- vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
- vtab = gfc_build_addr_expr (NULL_TREE, vtab);
- tmp = gfc_class_vptr_get (dest);
- gfc_add_modify (&block, tmp,
- fold_convert (TREE_TYPE (tmp), vtab));
- tmp = gfc_class_data_get (dest);
- tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
- gfc_add_expr_to_block (&block, tmp);
- }
- else if (init && cm->attr.allocatable && expr->expr_type == EXPR_NULL)
- {
- /* NULL initialization for allocatable components. */
- gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
- null_pointer_node));
- }
- else if (init && (cm->attr.allocatable
- || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
- && expr->ts.type != BT_CLASS)))
- {
- /* Take care about non-array allocatable components here. The alloc_*
- routine below is motivated by the alloc_scalar_allocatable_for_
- assignment() routine, but with the realloc portions removed and
- different input. */
- alloc_scalar_allocatable_for_subcomponent_assignment (&block,
- dest,
- cm,
- expr,
- sym);
- /* The remainder of these instructions follow the if (cm->attr.pointer)
- if (!cm->attr.dimension) part above. */
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, expr);
- gfc_add_block_to_block (&block, &se.pre);
-
- if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
- && expr->symtree->n.sym->attr.dummy)
- se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
-
- if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED)
- {
- tmp = gfc_class_data_get (dest);
- tmp = build_fold_indirect_ref_loc (input_location, tmp);
- vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
- vtab = gfc_build_addr_expr (NULL_TREE, vtab);
- gfc_add_modify (&block, gfc_class_vptr_get (dest),
- fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
- }
- else
- tmp = build_fold_indirect_ref_loc (input_location, dest);
-
- /* For deferred strings insert a memcpy. */
- if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
- {
- tree size;
- gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
- size = size_of_string_in_bytes (cm->ts.kind, se.string_length
- ? se.string_length
- : expr->ts.u.cl->backend_decl);
- tmp = gfc_build_memcpy_call (tmp, se.expr, size);
- gfc_add_expr_to_block (&block, tmp);
- }
- else
- gfc_add_modify (&block, tmp,
- fold_convert (TREE_TYPE (tmp), se.expr));
- gfc_add_block_to_block (&block, &se.post);
- }
- else if (expr->ts.type == BT_UNION)
- {
- tree tmp;
- gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
- /* We mark that the entire union should be initialized with a contrived
- EXPR_NULL expression at the beginning. */
- if (c != NULL && c->n.component == NULL
- && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
- {
- tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
- dest, build_constructor (TREE_TYPE (dest), NULL));
- gfc_add_expr_to_block (&block, tmp);
- c = gfc_constructor_next (c);
- }
- /* The following constructor expression, if any, represents a specific
- map intializer, as given by the user. */
- if (c != NULL && c->expr != NULL)
- {
- gcc_assert (expr->expr_type == EXPR_STRUCTURE);
- tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
- gfc_add_expr_to_block (&block, tmp);
- }
- }
- else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
- {
- if (expr->expr_type != EXPR_STRUCTURE)
- {
- tree dealloc = NULL_TREE;
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, expr);
- gfc_add_block_to_block (&block, &se.pre);
- /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
- expression in a temporary variable and deallocate the allocatable
- components. Then we can the copy the expression to the result. */
- if (cm->ts.u.derived->attr.alloc_comp
- && expr->expr_type != EXPR_VARIABLE)
- {
- se.expr = gfc_evaluate_now (se.expr, &block);
- dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
- expr->rank);
- }
- gfc_add_modify (&block, dest,
- fold_convert (TREE_TYPE (dest), se.expr));
- if (cm->ts.u.derived->attr.alloc_comp
- && expr->expr_type != EXPR_NULL)
- {
- // TODO: Fix caf_mode
- tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
- dest, expr->rank, 0);
- gfc_add_expr_to_block (&block, tmp);
- if (dealloc != NULL_TREE)
- gfc_add_expr_to_block (&block, dealloc);
- }
- gfc_add_block_to_block (&block, &se.post);
- }
- else
- {
- /* Nested constructors. */
- tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
- gfc_add_expr_to_block (&block, tmp);
- }
- }
- else if (gfc_deferred_strlen (cm, &tmp))
- {
- tree strlen;
- strlen = tmp;
- gcc_assert (strlen);
- strlen = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (strlen),
- TREE_OPERAND (dest, 0),
- strlen, NULL_TREE);
-
- if (expr->expr_type == EXPR_NULL)
- {
- tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
- gfc_add_modify (&block, dest, tmp);
- tmp = build_int_cst (TREE_TYPE (strlen), 0);
- gfc_add_modify (&block, strlen, tmp);
- }
- else
- {
- tree size;
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, expr);
- size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
- tmp = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_MALLOC),
- 1, size);
- gfc_add_modify (&block, dest,
- fold_convert (TREE_TYPE (dest), tmp));
- gfc_add_modify (&block, strlen,
- fold_convert (TREE_TYPE (strlen), se.string_length));
- tmp = gfc_build_memcpy_call (dest, se.expr, size);
- gfc_add_expr_to_block (&block, tmp);
- }
- }
- else if (!cm->attr.artificial)
- {
- /* Scalar component (excluding deferred parameters). */
- gfc_init_se (&se, NULL);
- gfc_init_se (&lse, NULL);
-
- gfc_conv_expr (&se, expr);
- if (cm->ts.type == BT_CHARACTER)
- lse.string_length = cm->ts.u.cl->backend_decl;
- lse.expr = dest;
- tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
- gfc_add_expr_to_block (&block, tmp);
- }
- return gfc_finish_block (&block);
-}
-
-/* Assign a derived type constructor to a variable. */
-
-tree
-gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
-{
- gfc_constructor *c;
- gfc_component *cm;
- stmtblock_t block;
- tree field;
- tree tmp;
- gfc_se se;
-
- gfc_start_block (&block);
-
- if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
- && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
- || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
- {
- gfc_se lse;
-
- gfc_init_se (&se, NULL);
- gfc_init_se (&lse, NULL);
- gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
- lse.expr = dest;
- gfc_add_modify (&block, lse.expr,
- fold_convert (TREE_TYPE (lse.expr), se.expr));
-
- return gfc_finish_block (&block);
- }
-
- /* Make sure that the derived type has been completely built. */
- if (!expr->ts.u.derived->backend_decl
- || !TYPE_FIELDS (expr->ts.u.derived->backend_decl))
- {
- tmp = gfc_typenode_for_spec (&expr->ts);
- gcc_assert (tmp);
- }
-
- cm = expr->ts.u.derived->components;
-
-
- if (coarray)
- gfc_init_se (&se, NULL);
-
- for (c = gfc_constructor_first (expr->value.constructor);
- c; c = gfc_constructor_next (c), cm = cm->next)
- {
- /* Skip absent members in default initializers. */
- if (!c->expr && !cm->attr.allocatable)
- continue;
-
- /* Register the component with the caf-lib before it is initialized.
- Register only allocatable components, that are not coarray'ed
- components (%comp[*]). Only register when the constructor is not the
- null-expression. */
- if (coarray && !cm->attr.codimension
- && (cm->attr.allocatable || cm->attr.pointer)
- && (!c->expr || c->expr->expr_type == EXPR_NULL))
- {
- tree token, desc, size;
- bool is_array = cm->ts.type == BT_CLASS
- ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
-
- field = cm->backend_decl;
- field = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field), dest, field, NULL_TREE);
- if (cm->ts.type == BT_CLASS)
- field = gfc_class_data_get (field);
-
- token = is_array ? gfc_conv_descriptor_token (field)
- : fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (cm->caf_token), dest,
- cm->caf_token, NULL_TREE);
-
- if (is_array)
- {
- /* The _caf_register routine looks at the rank of the array
- descriptor to decide whether the data registered is an array
- or not. */
- int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
- : cm->as->rank;
- /* When the rank is not known just set a positive rank, which
- suffices to recognize the data as array. */
- if (rank < 0)
- rank = 1;
- size = build_zero_cst (size_type_node);
- desc = field;
- gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
- build_int_cst (signed_char_type_node, rank));
- }
- else
- {
- desc = gfc_conv_scalar_to_descriptor (&se, field,
- cm->ts.type == BT_CLASS
- ? CLASS_DATA (cm)->attr
- : cm->attr);
- size = TYPE_SIZE_UNIT (TREE_TYPE (field));
- }
- gfc_add_block_to_block (&block, &se.pre);
- tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
- 7, size, build_int_cst (
- integer_type_node,
- GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
- gfc_build_addr_expr (pvoid_type_node,
- token),
- gfc_build_addr_expr (NULL_TREE, desc),
- null_pointer_node, null_pointer_node,
- integer_zero_node);
- gfc_add_expr_to_block (&block, tmp);
- }
- field = cm->backend_decl;
- gcc_assert(field);
- tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
- dest, field, NULL_TREE);
- if (!c->expr)
- {
- gfc_expr *e = gfc_get_null_expr (NULL);
- tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived,
- init);
- gfc_free_expr (e);
- }
- else
- tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr,
- expr->ts.u.derived, init);
- gfc_add_expr_to_block (&block, tmp);
- }
- return gfc_finish_block (&block);
-}
-
-void
-gfc_conv_union_initializer (vec<constructor_elt, va_gc> *v,
- gfc_component *un, gfc_expr *init)
-{
- gfc_constructor *ctor;
-
- if (un->ts.type != BT_UNION || un == NULL || init == NULL)
- return;
-
- ctor = gfc_constructor_first (init->value.constructor);
-
- if (ctor == NULL || ctor->expr == NULL)
- return;
-
- gcc_assert (init->expr_type == EXPR_STRUCTURE);
-
- /* If we have an 'initialize all' constructor, do it first. */
- if (ctor->expr->expr_type == EXPR_NULL)
- {
- tree union_type = TREE_TYPE (un->backend_decl);
- tree val = build_constructor (union_type, NULL);
- CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
- ctor = gfc_constructor_next (ctor);
- }
-
- /* Add the map initializer on top. */
- if (ctor != NULL && ctor->expr != NULL)
- {
- gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
- tree val = gfc_conv_initializer (ctor->expr, &un->ts,
- TREE_TYPE (un->backend_decl),
- un->attr.dimension, un->attr.pointer,
- un->attr.proc_pointer);
- CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
- }
-}
-
-/* Build an expression for a constructor. If init is nonzero then
- this is part of a static variable initializer. */
-
-void
-gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
-{
- gfc_constructor *c;
- gfc_component *cm;
- tree val;
- tree type;
- tree tmp;
- vec<constructor_elt, va_gc> *v = NULL;
-
- gcc_assert (se->ss == NULL);
- gcc_assert (expr->expr_type == EXPR_STRUCTURE);
- type = gfc_typenode_for_spec (&expr->ts);
-
- if (!init)
- {
- /* Create a temporary variable and fill it in. */
- se->expr = gfc_create_var (type, expr->ts.u.derived->name);
- /* The symtree in expr is NULL, if the code to generate is for
- initializing the static members only. */
- tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
- se->want_coarray);
- gfc_add_expr_to_block (&se->pre, tmp);
- return;
- }
-
- cm = expr->ts.u.derived->components;
-
- for (c = gfc_constructor_first (expr->value.constructor);
- c; c = gfc_constructor_next (c), cm = cm->next)
- {
- /* Skip absent members in default initializers and allocatable
- components. Although the latter have a default initializer
- of EXPR_NULL,... by default, the static nullify is not needed
- since this is done every time we come into scope. */
- if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
- continue;
-
- if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
- && strcmp (cm->name, "_extends") == 0
- && cm->initializer->symtree)
- {
- tree vtab;
- gfc_symbol *vtabs;
- vtabs = cm->initializer->symtree->n.sym;
- vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
- vtab = unshare_expr_without_location (vtab);
- CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
- }
- else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
- {
- val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
- CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
- fold_convert (TREE_TYPE (cm->backend_decl),
- val));
- }
- else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
- CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
- fold_convert (TREE_TYPE (cm->backend_decl),
- integer_zero_node));
- else if (cm->ts.type == BT_UNION)
- gfc_conv_union_initializer (v, cm, c->expr);
- else
- {
- val = gfc_conv_initializer (c->expr, &cm->ts,
- TREE_TYPE (cm->backend_decl),
- cm->attr.dimension, cm->attr.pointer,
- cm->attr.proc_pointer);
- val = unshare_expr_without_location (val);
-
- /* Append it to the constructor list. */
- CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
- }
- }
-
- se->expr = build_constructor (type, v);
- if (init)
- TREE_CONSTANT (se->expr) = 1;
-}
-
-
-/* Translate a substring expression. */
-
-static void
-gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
-{
- gfc_ref *ref;
-
- ref = expr->ref;
-
- gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
-
- se->expr = gfc_build_wide_string_const (expr->ts.kind,
- expr->value.character.length,
- expr->value.character.string);
-
- se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
- TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
-
- if (ref)
- gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
-}
-
-
-/* Entry point for expression translation. Evaluates a scalar quantity.
- EXPR is the expression to be translated, and SE is the state structure if
- called from within the scalarized. */
-
-void
-gfc_conv_expr (gfc_se * se, gfc_expr * expr)
-{
- gfc_ss *ss;
-
- ss = se->ss;
- if (ss && ss->info->expr == expr
- && (ss->info->type == GFC_SS_SCALAR
- || ss->info->type == GFC_SS_REFERENCE))
- {
- gfc_ss_info *ss_info;
-
- ss_info = ss->info;
- /* Substitute a scalar expression evaluated outside the scalarization
- loop. */
- se->expr = ss_info->data.scalar.value;
- if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
- se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
-
- se->string_length = ss_info->string_length;
- gfc_advance_se_ss_chain (se);
- return;
- }
-
- /* We need to convert the expressions for the iso_c_binding derived types.
- C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
- null_pointer_node. C_PTR and C_FUNPTR are converted to match the
- typespec for the C_PTR and C_FUNPTR symbols, which has already been
- updated to be an integer with a kind equal to the size of a (void *). */
- if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
- && expr->ts.u.derived->attr.is_bind_c)
- {
- if (expr->expr_type == EXPR_VARIABLE
- && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
- || expr->symtree->n.sym->intmod_sym_id
- == ISOCBINDING_NULL_FUNPTR))
- {
- /* Set expr_type to EXPR_NULL, which will result in
- null_pointer_node being used below. */
- expr->expr_type = EXPR_NULL;
- }
- else
- {
- /* Update the type/kind of the expression to be what the new
- type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
- expr->ts.type = BT_INTEGER;
- expr->ts.f90_type = BT_VOID;
- expr->ts.kind = gfc_index_integer_kind;
- }
- }
-
- gfc_fix_class_refs (expr);
-
- switch (expr->expr_type)
- {
- case EXPR_OP:
- gfc_conv_expr_op (se, expr);
- break;
-
- case EXPR_FUNCTION:
- gfc_conv_function_expr (se, expr);
- break;
-
- case EXPR_CONSTANT:
- gfc_conv_constant (se, expr);
- break;
-
- case EXPR_VARIABLE:
- gfc_conv_variable (se, expr);
- break;
-
- case EXPR_NULL:
- se->expr = null_pointer_node;
- break;
-
- case EXPR_SUBSTRING:
- gfc_conv_substring_expr (se, expr);
- break;
-
- case EXPR_STRUCTURE:
- gfc_conv_structure (se, expr, 0);
- break;
-
- case EXPR_ARRAY:
- gfc_conv_array_constructor_expr (se, expr);
- break;
-
- default:
- gcc_unreachable ();
- break;
- }
-}
-
-/* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
- of an assignment. */
-void
-gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
-{
- gfc_conv_expr (se, expr);
- /* All numeric lvalues should have empty post chains. If not we need to
- figure out a way of rewriting an lvalue so that it has no post chain. */
- gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
-}
-
-/* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
- numeric expressions. Used for scalar values where inserting cleanup code
- is inconvenient. */
-void
-gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
-{
- tree val;
-
- gcc_assert (expr->ts.type != BT_CHARACTER);
- gfc_conv_expr (se, expr);
- if (se->post.head)
- {
- val = gfc_create_var (TREE_TYPE (se->expr), NULL);
- gfc_add_modify (&se->pre, val, se->expr);
- se->expr = val;
- gfc_add_block_to_block (&se->pre, &se->post);
- }
-}
-
-/* Helper to translate an expression and convert it to a particular type. */
-void
-gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
-{
- gfc_conv_expr_val (se, expr);
- se->expr = convert (type, se->expr);
-}
-
-
-/* Converts an expression so that it can be passed by reference. Scalar
- values only. */
-
-void
-gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr, bool add_clobber)
-{
- gfc_ss *ss;
- tree var;
-
- ss = se->ss;
- if (ss && ss->info->expr == expr
- && ss->info->type == GFC_SS_REFERENCE)
- {
- /* Returns a reference to the scalar evaluated outside the loop
- for this case. */
- gfc_conv_expr (se, expr);
-
- if (expr->ts.type == BT_CHARACTER
- && expr->expr_type != EXPR_FUNCTION)
- gfc_conv_string_parameter (se);
- else
- se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
-
- return;
- }
-
- if (expr->ts.type == BT_CHARACTER)
- {
- gfc_conv_expr (se, expr);
- gfc_conv_string_parameter (se);
- return;
- }
-
- if (expr->expr_type == EXPR_VARIABLE)
- {
- se->want_pointer = 1;
- gfc_conv_expr (se, expr);
- if (se->post.head)
- {
- var = gfc_create_var (TREE_TYPE (se->expr), NULL);
- gfc_add_modify (&se->pre, var, se->expr);
- gfc_add_block_to_block (&se->pre, &se->post);
- se->expr = var;
- }
- else if (add_clobber && expr->ref == NULL)
- {
- tree clobber;
- tree var;
- /* FIXME: This fails if var is passed by reference, see PR
- 41453. */
- var = expr->symtree->n.sym->backend_decl;
- clobber = build_clobber (TREE_TYPE (var));
- gfc_add_modify (&se->pre, var, clobber);
- }
- return;
- }
-
- if (expr->expr_type == EXPR_FUNCTION
- && ((expr->value.function.esym
- && expr->value.function.esym->result
- && expr->value.function.esym->result->attr.pointer
- && !expr->value.function.esym->result->attr.dimension)
- || (!expr->value.function.esym && !expr->ref
- && expr->symtree->n.sym->attr.pointer
- && !expr->symtree->n.sym->attr.dimension)))
- {
- se->want_pointer = 1;
- gfc_conv_expr (se, expr);
- var = gfc_create_var (TREE_TYPE (se->expr), NULL);
- gfc_add_modify (&se->pre, var, se->expr);
- se->expr = var;
- return;
- }
-
- gfc_conv_expr (se, expr);
-
- /* Create a temporary var to hold the value. */
- if (TREE_CONSTANT (se->expr))
- {
- tree tmp = se->expr;
- STRIP_TYPE_NOPS (tmp);
- var = build_decl (input_location,
- CONST_DECL, NULL, TREE_TYPE (tmp));
- DECL_INITIAL (var) = tmp;
- TREE_STATIC (var) = 1;
- pushdecl (var);
- }
- else
- {
- var = gfc_create_var (TREE_TYPE (se->expr), NULL);
- gfc_add_modify (&se->pre, var, se->expr);
- }
-
- if (!expr->must_finalize)
- gfc_add_block_to_block (&se->pre, &se->post);
-
- /* Take the address of that value. */
- se->expr = gfc_build_addr_expr (NULL_TREE, var);
-}
-
-
-/* Get the _len component for an unlimited polymorphic expression. */
-
-static tree
-trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
-{
- gfc_se se;
- gfc_ref *ref = expr->ref;
-
- gfc_init_se (&se, NULL);
- while (ref && ref->next)
- ref = ref->next;
- gfc_add_len_component (expr);
- gfc_conv_expr (&se, expr);
- gfc_add_block_to_block (block, &se.pre);
- gcc_assert (se.post.head == NULL_TREE);
- if (ref)
- {
- gfc_free_ref_list (ref->next);
- ref->next = NULL;
- }
- else
- {
- gfc_free_ref_list (expr->ref);
- expr->ref = NULL;
- }
- return se.expr;
-}
-
-
-/* Assign _vptr and _len components as appropriate. BLOCK should be a
- statement-list outside of the scalarizer-loop. When code is generated, that
- depends on the scalarized expression, it is added to RSE.PRE.
- Returns le's _vptr tree and when set the len expressions in to_lenp and
- from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
- expression. */
-
-static tree
-trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
- gfc_expr * re, gfc_se *rse,
- tree * to_lenp, tree * from_lenp)
-{
- gfc_se se;
- gfc_expr * vptr_expr;
- tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
- bool set_vptr = false, temp_rhs = false;
- stmtblock_t *pre = block;
- tree class_expr = NULL_TREE;
-
- /* Create a temporary for complicated expressions. */
- if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
- && rse->expr != NULL_TREE && !DECL_P (rse->expr))
- {
- if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
- class_expr = gfc_get_class_from_expr (rse->expr);
-
- if (rse->loop)
- pre = &rse->loop->pre;
- else
- pre = &rse->pre;
-
- if (class_expr != NULL_TREE && UNLIMITED_POLY (re))
- {
- tmp = TREE_OPERAND (rse->expr, 0);
- tmp = gfc_create_var (TREE_TYPE (tmp), "rhs");
- gfc_add_modify (&rse->pre, tmp, TREE_OPERAND (rse->expr, 0));
- }
- else
- {
- tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
- gfc_add_modify (&rse->pre, tmp, rse->expr);
- }
-
- rse->expr = tmp;
- temp_rhs = true;
- }
-
- /* Get the _vptr for the left-hand side expression. */
- gfc_init_se (&se, NULL);
- vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
- if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
- {
- /* Care about _len for unlimited polymorphic entities. */
- if (UNLIMITED_POLY (vptr_expr)
- || (vptr_expr->ts.type == BT_DERIVED
- && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
- to_len = trans_get_upoly_len (block, vptr_expr);
- gfc_add_vptr_component (vptr_expr);
- set_vptr = true;
- }
- else
- vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
- se.want_pointer = 1;
- gfc_conv_expr (&se, vptr_expr);
- gfc_free_expr (vptr_expr);
- gfc_add_block_to_block (block, &se.pre);
- gcc_assert (se.post.head == NULL_TREE);
- lhs_vptr = se.expr;
- STRIP_NOPS (lhs_vptr);
-
- /* Set the _vptr only when the left-hand side of the assignment is a
- class-object. */
- if (set_vptr)
- {
- /* Get the vptr from the rhs expression only, when it is variable.
- Functions are expected to be assigned to a temporary beforehand. */
- vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
- ? gfc_find_and_cut_at_last_class_ref (re)
- : NULL;
- if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
- {
- if (to_len != NULL_TREE)
- {
- /* Get the _len information from the rhs. */
- if (UNLIMITED_POLY (vptr_expr)
- || (vptr_expr->ts.type == BT_DERIVED
- && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
- from_len = trans_get_upoly_len (block, vptr_expr);
- }
- gfc_add_vptr_component (vptr_expr);
- }
- else
- {
- if (re->expr_type == EXPR_VARIABLE
- && DECL_P (re->symtree->n.sym->backend_decl)
- && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
- && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
- && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
- re->symtree->n.sym->backend_decl))))
- {
- vptr_expr = NULL;
- se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
- re->symtree->n.sym->backend_decl));
- if (to_len)
- from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
- re->symtree->n.sym->backend_decl));
- }
- else if (temp_rhs && re->ts.type == BT_CLASS)
- {
- vptr_expr = NULL;
- if (class_expr)
- tmp = class_expr;
- else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
- tmp = gfc_get_class_from_expr (rse->expr);
- else
- tmp = rse->expr;
-
- se.expr = gfc_class_vptr_get (tmp);
- if (UNLIMITED_POLY (re))
- from_len = gfc_class_len_get (tmp);
-
- }
- else if (re->expr_type != EXPR_NULL)
- /* Only when rhs is non-NULL use its declared type for vptr
- initialisation. */
- vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
- else
- /* When the rhs is NULL use the vtab of lhs' declared type. */
- vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
- }
-
- if (vptr_expr)
- {
- gfc_init_se (&se, NULL);
- se.want_pointer = 1;
- gfc_conv_expr (&se, vptr_expr);
- gfc_free_expr (vptr_expr);
- gfc_add_block_to_block (block, &se.pre);
- gcc_assert (se.post.head == NULL_TREE);
- }
- gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
- se.expr));
-
- if (to_len != NULL_TREE)
- {
- /* The _len component needs to be set. Figure how to get the
- value of the right-hand side. */
- if (from_len == NULL_TREE)
- {
- if (rse->string_length != NULL_TREE)
- from_len = rse->string_length;
- else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
- {
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, re->ts.u.cl->length);
- gfc_add_block_to_block (block, &se.pre);
- gcc_assert (se.post.head == NULL_TREE);
- from_len = gfc_evaluate_now (se.expr, block);
- }
- else
- from_len = build_zero_cst (gfc_charlen_type_node);
- }
- gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
- from_len));
- }
- }
-
- /* Return the _len trees only, when requested. */
- if (to_lenp)
- *to_lenp = to_len;
- if (from_lenp)
- *from_lenp = from_len;
- return lhs_vptr;
-}
-
-
-/* Assign tokens for pointer components. */
-
-static void
-trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
- gfc_expr *expr2)
-{
- symbol_attribute lhs_attr, rhs_attr;
- tree tmp, lhs_tok, rhs_tok;
- /* Flag to indicated component refs on the rhs. */
- bool rhs_cr;
-
- lhs_attr = gfc_caf_attr (expr1);
- if (expr2->expr_type != EXPR_NULL)
- {
- rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
- if (lhs_attr.codimension && rhs_attr.codimension)
- {
- lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
- lhs_tok = build_fold_indirect_ref (lhs_tok);
-
- if (rhs_cr)
- rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
- else
- {
- tree caf_decl;
- caf_decl = gfc_get_tree_for_caf_expr (expr2);
- gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
- NULL_TREE, NULL);
- }
- tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
- lhs_tok,
- fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
- gfc_prepend_expr_to_block (&lse->post, tmp);
- }
- }
- else if (lhs_attr.codimension)
- {
- lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
- lhs_tok = build_fold_indirect_ref (lhs_tok);
- tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
- lhs_tok, null_pointer_node);
- gfc_prepend_expr_to_block (&lse->post, tmp);
- }
-}
-
-
-/* Do everything that is needed for a CLASS function expr2. */
-
-static tree
-trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
- gfc_expr *expr1, gfc_expr *expr2)
-{
- tree expr1_vptr = NULL_TREE;
- tree tmp;
-
- gfc_conv_function_expr (rse, expr2);
- rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
-
- if (expr1->ts.type != BT_CLASS)
- rse->expr = gfc_class_data_get (rse->expr);
- else
- {
- expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
- expr2, rse,
- NULL, NULL);
- gfc_add_block_to_block (block, &rse->pre);
- tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
- gfc_add_modify (&lse->pre, tmp, rse->expr);
-
- gfc_add_modify (&lse->pre, expr1_vptr,
- fold_convert (TREE_TYPE (expr1_vptr),
- gfc_class_vptr_get (tmp)));
- rse->expr = gfc_class_data_get (tmp);
- }
-
- return expr1_vptr;
-}
-
-
-tree
-gfc_trans_pointer_assign (gfc_code * code)
-{
- return gfc_trans_pointer_assignment (code->expr1, code->expr2);
-}
-
-
-/* Generate code for a pointer assignment. */
-
-tree
-gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
-{
- gfc_se lse;
- gfc_se rse;
- stmtblock_t block;
- tree desc;
- tree tmp;
- tree expr1_vptr = NULL_TREE;
- bool scalar, non_proc_ptr_assign;
- gfc_ss *ss;
-
- gfc_start_block (&block);
-
- gfc_init_se (&lse, NULL);
-
- /* Usually testing whether this is not a proc pointer assignment. */
- non_proc_ptr_assign = !(gfc_expr_attr (expr1).proc_pointer
- && expr2->expr_type == EXPR_VARIABLE
- && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE);
-
- /* Check whether the expression is a scalar or not; we cannot use
- expr1->rank as it can be nonzero for proc pointers. */
- ss = gfc_walk_expr (expr1);
- scalar = ss == gfc_ss_terminator;
- if (!scalar)
- gfc_free_ss_chain (ss);
-
- if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
- && expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign)
- {
- gfc_add_data_component (expr2);
- /* The following is required as gfc_add_data_component doesn't
- update ts.type if there is a trailing REF_ARRAY. */
- expr2->ts.type = BT_DERIVED;
- }
-
- if (scalar)
- {
- /* Scalar pointers. */
- lse.want_pointer = 1;
- gfc_conv_expr (&lse, expr1);
- gfc_init_se (&rse, NULL);
- rse.want_pointer = 1;
- if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
- trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
- else
- gfc_conv_expr (&rse, expr2);
-
- if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
- {
- trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
- NULL);
- lse.expr = gfc_class_data_get (lse.expr);
- }
-
- if (expr1->symtree->n.sym->attr.proc_pointer
- && expr1->symtree->n.sym->attr.dummy)
- lse.expr = build_fold_indirect_ref_loc (input_location,
- lse.expr);
-
- if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
- && expr2->symtree->n.sym->attr.dummy)
- rse.expr = build_fold_indirect_ref_loc (input_location,
- rse.expr);
-
- gfc_add_block_to_block (&block, &lse.pre);
- gfc_add_block_to_block (&block, &rse.pre);
-
- /* Check character lengths if character expression. The test is only
- really added if -fbounds-check is enabled. Exclude deferred
- character length lefthand sides. */
- if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
- && !expr1->ts.deferred
- && !expr1->symtree->n.sym->attr.proc_pointer
- && !gfc_is_proc_ptr_comp (expr1))
- {
- gcc_assert (expr2->ts.type == BT_CHARACTER);
- gcc_assert (lse.string_length && rse.string_length);
- gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
- lse.string_length, rse.string_length,
- &block);
- }
-
- /* The assignment to an deferred character length sets the string
- length to that of the rhs. */
- if (expr1->ts.deferred)
- {
- if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
- gfc_add_modify (&block, lse.string_length,
- fold_convert (TREE_TYPE (lse.string_length),
- rse.string_length));
- else if (lse.string_length != NULL)
- gfc_add_modify (&block, lse.string_length,
- build_zero_cst (TREE_TYPE (lse.string_length)));
- }
-
- gfc_add_modify (&block, lse.expr,
- fold_convert (TREE_TYPE (lse.expr), rse.expr));
-
- /* Also set the tokens for pointer components in derived typed
- coarrays. */
- if (flag_coarray == GFC_FCOARRAY_LIB)
- trans_caf_token_assign (&lse, &rse, expr1, expr2);
-
- gfc_add_block_to_block (&block, &rse.post);
- gfc_add_block_to_block (&block, &lse.post);
- }
- else
- {
- gfc_ref* remap;
- bool rank_remap;
- tree strlen_lhs;
- tree strlen_rhs = NULL_TREE;
-
- /* Array pointer. Find the last reference on the LHS and if it is an
- array section ref, we're dealing with bounds remapping. In this case,
- set it to AR_FULL so that gfc_conv_expr_descriptor does
- not see it and process the bounds remapping afterwards explicitly. */
- for (remap = expr1->ref; remap; remap = remap->next)
- if (!remap->next && remap->type == REF_ARRAY
- && remap->u.ar.type == AR_SECTION)
- break;
- rank_remap = (remap && remap->u.ar.end[0]);
-
- if (remap && expr2->expr_type == EXPR_NULL)
- {
- gfc_error ("If bounds remapping is specified at %L, "
- "the pointer target shall not be NULL", &expr1->where);
- return NULL_TREE;
- }
-
- gfc_init_se (&lse, NULL);
- if (remap)
- lse.descriptor_only = 1;
- gfc_conv_expr_descriptor (&lse, expr1);
- strlen_lhs = lse.string_length;
- desc = lse.expr;
-
- if (expr2->expr_type == EXPR_NULL)
- {
- /* Just set the data pointer to null. */
- gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
- }
- else if (rank_remap)
- {
- /* If we are rank-remapping, just get the RHS's descriptor and
- process this later on. */
- gfc_init_se (&rse, NULL);
- rse.direct_byref = 1;
- rse.byref_noassign = 1;
-
- if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
- expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
- expr1, expr2);
- else if (expr2->expr_type == EXPR_FUNCTION)
- {
- tree bound[GFC_MAX_DIMENSIONS];
- int i;
-
- for (i = 0; i < expr2->rank; i++)
- bound[i] = NULL_TREE;
- tmp = gfc_typenode_for_spec (&expr2->ts);
- tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
- bound, bound, 0,
- GFC_ARRAY_POINTER_CONT, false);
- tmp = gfc_create_var (tmp, "ptrtemp");
- rse.descriptor_only = 0;
- rse.expr = tmp;
- rse.direct_byref = 1;
- gfc_conv_expr_descriptor (&rse, expr2);
- strlen_rhs = rse.string_length;
- rse.expr = tmp;
- }
- else
- {
- gfc_conv_expr_descriptor (&rse, expr2);
- strlen_rhs = rse.string_length;
- if (expr1->ts.type == BT_CLASS)
- expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
- expr2, &rse,
- NULL, NULL);
- }
- }
- else if (expr2->expr_type == EXPR_VARIABLE)
- {
- /* Assign directly to the LHS's descriptor. */
- lse.descriptor_only = 0;
- lse.direct_byref = 1;
- gfc_conv_expr_descriptor (&lse, expr2);
- strlen_rhs = lse.string_length;
- gfc_init_se (&rse, NULL);
-
- if (expr1->ts.type == BT_CLASS)
- {
- rse.expr = NULL_TREE;
- rse.string_length = strlen_rhs;
- trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
- NULL, NULL);
- }
-
- if (remap == NULL)
- {
- /* If the target is not a whole array, use the target array
- reference for remap. */
- for (remap = expr2->ref; remap; remap = remap->next)
- if (remap->type == REF_ARRAY
- && remap->u.ar.type == AR_FULL
- && remap->next)
- break;
- }
- }
- else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
- {
- gfc_init_se (&rse, NULL);
- rse.want_pointer = 1;
- gfc_conv_function_expr (&rse, expr2);
- if (expr1->ts.type != BT_CLASS)
- {
- rse.expr = gfc_class_data_get (rse.expr);
- gfc_add_modify (&lse.pre, desc, rse.expr);
- /* Set the lhs span. */
- tmp = TREE_TYPE (rse.expr);
- tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
- tmp = fold_convert (gfc_array_index_type, tmp);
- gfc_conv_descriptor_span_set (&lse.pre, desc, tmp);
- }
- else
- {
- expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
- expr2, &rse, NULL,
- NULL);
- gfc_add_block_to_block (&block, &rse.pre);
- tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
- gfc_add_modify (&lse.pre, tmp, rse.expr);
-
- gfc_add_modify (&lse.pre, expr1_vptr,
- fold_convert (TREE_TYPE (expr1_vptr),
- gfc_class_vptr_get (tmp)));
- rse.expr = gfc_class_data_get (tmp);
- gfc_add_modify (&lse.pre, desc, rse.expr);
- }
- }
- else
- {
- /* Assign to a temporary descriptor and then copy that
- temporary to the pointer. */
- tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
- lse.descriptor_only = 0;
- lse.expr = tmp;
- lse.direct_byref = 1;
- gfc_conv_expr_descriptor (&lse, expr2);
- strlen_rhs = lse.string_length;
- gfc_add_modify (&lse.pre, desc, tmp);
- }
-
- if (expr1->ts.type == BT_CHARACTER
- && expr1->symtree->n.sym->ts.deferred
- && expr1->symtree->n.sym->ts.u.cl->backend_decl
- && VAR_P (expr1->symtree->n.sym->ts.u.cl->backend_decl))
- {
- tmp = expr1->symtree->n.sym->ts.u.cl->backend_decl;
- if (expr2->expr_type != EXPR_NULL)
- gfc_add_modify (&block, tmp,
- fold_convert (TREE_TYPE (tmp), strlen_rhs));
- else
- gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
- }
-
- gfc_add_block_to_block (&block, &lse.pre);
- if (rank_remap)
- gfc_add_block_to_block (&block, &rse.pre);
-
- /* If we do bounds remapping, update LHS descriptor accordingly. */
- if (remap)
- {
- int dim;
- gcc_assert (remap->u.ar.dimen == expr1->rank);
-
- if (rank_remap)
- {
- /* Do rank remapping. We already have the RHS's descriptor
- converted in rse and now have to build the correct LHS
- descriptor for it. */
-
- tree dtype, data, span;
- tree offs, stride;
- tree lbound, ubound;
-
- /* Set dtype. */
- dtype = gfc_conv_descriptor_dtype (desc);
- tmp = gfc_get_dtype (TREE_TYPE (desc));
- gfc_add_modify (&block, dtype, tmp);
-
- /* Copy data pointer. */
- data = gfc_conv_descriptor_data_get (rse.expr);
- gfc_conv_descriptor_data_set (&block, desc, data);
-
- /* Copy the span. */
- if (TREE_CODE (rse.expr) == VAR_DECL
- && GFC_DECL_PTR_ARRAY_P (rse.expr))
- span = gfc_conv_descriptor_span_get (rse.expr);
- else
- {
- tmp = TREE_TYPE (rse.expr);
- tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
- span = fold_convert (gfc_array_index_type, tmp);
- }
- gfc_conv_descriptor_span_set (&block, desc, span);
-
- /* Copy offset but adjust it such that it would correspond
- to a lbound of zero. */
- offs = gfc_conv_descriptor_offset_get (rse.expr);
- for (dim = 0; dim < expr2->rank; ++dim)
- {
- stride = gfc_conv_descriptor_stride_get (rse.expr,
- gfc_rank_cst[dim]);
- lbound = gfc_conv_descriptor_lbound_get (rse.expr,
- gfc_rank_cst[dim]);
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, stride, lbound);
- offs = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, offs, tmp);
- }
- gfc_conv_descriptor_offset_set (&block, desc, offs);
-
- /* Set the bounds as declared for the LHS and calculate strides as
- well as another offset update accordingly. */
- stride = gfc_conv_descriptor_stride_get (rse.expr,
- gfc_rank_cst[0]);
- for (dim = 0; dim < expr1->rank; ++dim)
- {
- gfc_se lower_se;
- gfc_se upper_se;
-
- gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
-
- /* Convert declared bounds. */
- gfc_init_se (&lower_se, NULL);
- gfc_init_se (&upper_se, NULL);
- gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
- gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
-
- gfc_add_block_to_block (&block, &lower_se.pre);
- gfc_add_block_to_block (&block, &upper_se.pre);
-
- lbound = fold_convert (gfc_array_index_type, lower_se.expr);
- ubound = fold_convert (gfc_array_index_type, upper_se.expr);
-
- lbound = gfc_evaluate_now (lbound, &block);
- ubound = gfc_evaluate_now (ubound, &block);
-
- gfc_add_block_to_block (&block, &lower_se.post);
- gfc_add_block_to_block (&block, &upper_se.post);
-
- /* Set bounds in descriptor. */
- gfc_conv_descriptor_lbound_set (&block, desc,
- gfc_rank_cst[dim], lbound);
- gfc_conv_descriptor_ubound_set (&block, desc,
- gfc_rank_cst[dim], ubound);
-
- /* Set stride. */
- stride = gfc_evaluate_now (stride, &block);
- gfc_conv_descriptor_stride_set (&block, desc,
- gfc_rank_cst[dim], stride);
-
- /* Update offset. */
- offs = gfc_conv_descriptor_offset_get (desc);
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, lbound, stride);
- offs = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, offs, tmp);
- offs = gfc_evaluate_now (offs, &block);
- gfc_conv_descriptor_offset_set (&block, desc, offs);
-
- /* Update stride. */
- tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
- stride = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, stride, tmp);
- }
- }
- else
- {
- /* Bounds remapping. Just shift the lower bounds. */
-
- gcc_assert (expr1->rank == expr2->rank);
-
- for (dim = 0; dim < remap->u.ar.dimen; ++dim)
- {
- gfc_se lbound_se;
-
- gcc_assert (!remap->u.ar.end[dim]);
- gfc_init_se (&lbound_se, NULL);
- if (remap->u.ar.start[dim])
- {
- gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
- gfc_add_block_to_block (&block, &lbound_se.pre);
- }
- else
- /* This remap arises from a target that is not a whole
- array. The start expressions will be NULL but we need
- the lbounds to be one. */
- lbound_se.expr = gfc_index_one_node;
- gfc_conv_shift_descriptor_lbound (&block, desc,
- dim, lbound_se.expr);
- gfc_add_block_to_block (&block, &lbound_se.post);
- }
- }
- }
-
- /* If rank remapping was done, check with -fcheck=bounds that
- the target is at least as large as the pointer. */
- if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
- {
- tree lsize, rsize;
- tree fault;
- const char* msg;
-
- lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
- rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
-
- lsize = gfc_evaluate_now (lsize, &block);
- rsize = gfc_evaluate_now (rsize, &block);
- fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
- rsize, lsize);
-
- msg = _("Target of rank remapping is too small (%ld < %ld)");
- gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
- msg, rsize, lsize);
- }
-
- /* Check string lengths if applicable. The check is only really added
- to the output code if -fbounds-check is enabled. */
- if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
- {
- gcc_assert (expr2->ts.type == BT_CHARACTER);
- gcc_assert (strlen_lhs && strlen_rhs);
- gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
- strlen_lhs, strlen_rhs, &block);
- }
-
- gfc_add_block_to_block (&block, &lse.post);
- if (rank_remap)
- gfc_add_block_to_block (&block, &rse.post);
- }
-
- return gfc_finish_block (&block);
-}
-
-
-/* Makes sure se is suitable for passing as a function string parameter. */
-/* TODO: Need to check all callers of this function. It may be abused. */
-
-void
-gfc_conv_string_parameter (gfc_se * se)
-{
- tree type;
-
- if (TREE_CODE (se->expr) == STRING_CST)
- {
- type = TREE_TYPE (TREE_TYPE (se->expr));
- se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
- return;
- }
-
- if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
- || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
- && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
- {
- if (TREE_CODE (se->expr) != INDIRECT_REF)
- {
- type = TREE_TYPE (se->expr);
- se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
- }
- else
- {
- type = gfc_get_character_type_len (gfc_default_character_kind,
- se->string_length);
- type = build_pointer_type (type);
- se->expr = gfc_build_addr_expr (type, se->expr);
- }
- }
-
- gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
-}
-
-
-/* Generate code for assignment of scalar variables. Includes character
- strings and derived types with allocatable components.
- If you know that the LHS has no allocations, set dealloc to false.
-
- DEEP_COPY has no effect if the typespec TS is not a derived type with
- allocatable components. Otherwise, if it is set, an explicit copy of each
- allocatable component is made. This is necessary as a simple copy of the
- whole object would copy array descriptors as is, so that the lhs's
- allocatable components would point to the rhs's after the assignment.
- Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
- necessary if the rhs is a non-pointer function, as the allocatable components
- are not accessible by other means than the function's result after the
- function has returned. It is even more subtle when temporaries are involved,
- as the two following examples show:
- 1. When we evaluate an array constructor, a temporary is created. Thus
- there is theoretically no alias possible. However, no deep copy is
- made for this temporary, so that if the constructor is made of one or
- more variable with allocatable components, those components still point
- to the variable's: DEEP_COPY should be set for the assignment from the
- temporary to the lhs in that case.
- 2. When assigning a scalar to an array, we evaluate the scalar value out
- of the loop, store it into a temporary variable, and assign from that.
- In that case, deep copying when assigning to the temporary would be a
- waste of resources; however deep copies should happen when assigning from
- the temporary to each array element: again DEEP_COPY should be set for
- the assignment from the temporary to the lhs. */
-
-tree
-gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
- bool deep_copy, bool dealloc, bool in_coarray)
-{
- stmtblock_t block;
- tree tmp;
- tree cond;
-
- gfc_init_block (&block);
-
- if (ts.type == BT_CHARACTER)
- {
- tree rlen = NULL;
- tree llen = NULL;
-
- if (lse->string_length != NULL_TREE)
- {
- gfc_conv_string_parameter (lse);
- gfc_add_block_to_block (&block, &lse->pre);
- llen = lse->string_length;
- }
-
- if (rse->string_length != NULL_TREE)
- {
- gfc_conv_string_parameter (rse);
- gfc_add_block_to_block (&block, &rse->pre);
- rlen = rse->string_length;
- }
-
- gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
- rse->expr, ts.kind);
- }
- else if (gfc_bt_struct (ts.type)
- && (ts.u.derived->attr.alloc_comp
- || (deep_copy && ts.u.derived->attr.pdt_type)))
- {
- tree tmp_var = NULL_TREE;
- cond = NULL_TREE;
-
- /* Are the rhs and the lhs the same? */
- if (deep_copy)
- {
- cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
- gfc_build_addr_expr (NULL_TREE, lse->expr),
- gfc_build_addr_expr (NULL_TREE, rse->expr));
- cond = gfc_evaluate_now (cond, &lse->pre);
- }
-
- /* Deallocate the lhs allocated components as long as it is not
- the same as the rhs. This must be done following the assignment
- to prevent deallocating data that could be used in the rhs
- expression. */
- if (dealloc)
- {
- tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
- tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
- if (deep_copy)
- tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
- tmp);
- gfc_add_expr_to_block (&lse->post, tmp);
- }
-
- gfc_add_block_to_block (&block, &rse->pre);
- gfc_add_block_to_block (&block, &lse->pre);
-
- gfc_add_modify (&block, lse->expr,
- fold_convert (TREE_TYPE (lse->expr), rse->expr));
-
- /* Restore pointer address of coarray components. */
- if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
- {
- tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
- tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
- tmp);
- gfc_add_expr_to_block (&block, tmp);
- }
-
- /* Do a deep copy if the rhs is a variable, if it is not the
- same as the lhs. */
- if (deep_copy)
- {
- int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
- | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
- tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
- caf_mode);
- tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
- tmp);
- gfc_add_expr_to_block (&block, tmp);
- }
- }
- else if (gfc_bt_struct (ts.type))
- {
- gfc_add_block_to_block (&block, &lse->pre);
- gfc_add_block_to_block (&block, &rse->pre);
- tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
- TREE_TYPE (lse->expr), rse->expr);
- gfc_add_modify (&block, lse->expr, tmp);
- }
- /* If possible use the rhs vptr copy with trans_scalar_class_assign.... */
- else if (ts.type == BT_CLASS)
- {
- gfc_add_block_to_block (&block, &lse->pre);
- gfc_add_block_to_block (&block, &rse->pre);
-
- if (!trans_scalar_class_assign (&block, lse, rse))
- {
- /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
- for the lhs which ensures that class data rhs cast as a string assigns
- correctly. */
- tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
- TREE_TYPE (rse->expr), lse->expr);
- gfc_add_modify (&block, tmp, rse->expr);
- }
- }
- else if (ts.type != BT_CLASS)
- {
- gfc_add_block_to_block (&block, &lse->pre);
- gfc_add_block_to_block (&block, &rse->pre);
-
- gfc_add_modify (&block, lse->expr,
- fold_convert (TREE_TYPE (lse->expr), rse->expr));
- }
-
- gfc_add_block_to_block (&block, &lse->post);
- gfc_add_block_to_block (&block, &rse->post);
-
- return gfc_finish_block (&block);
-}
-
-
-/* There are quite a lot of restrictions on the optimisation in using an
- array function assign without a temporary. */
-
-static bool
-arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
-{
- gfc_ref * ref;
- bool seen_array_ref;
- bool c = false;
- gfc_symbol *sym = expr1->symtree->n.sym;
-
- /* Play it safe with class functions assigned to a derived type. */
- if (gfc_is_class_array_function (expr2)
- && expr1->ts.type == BT_DERIVED)
- return true;
-
- /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
- if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
- return true;
-
- /* Elemental functions are scalarized so that they don't need a
- temporary in gfc_trans_assignment_1, so return a true. Otherwise,
- they would need special treatment in gfc_trans_arrayfunc_assign. */
- if (expr2->value.function.esym != NULL
- && expr2->value.function.esym->attr.elemental)
- return true;
-
- /* Need a temporary if rhs is not FULL or a contiguous section. */
- if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
- return true;
-
- /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
- if (gfc_ref_needs_temporary_p (expr1->ref))
- return true;
-
- /* Functions returning pointers or allocatables need temporaries. */
- if (gfc_expr_attr (expr2).pointer
- || gfc_expr_attr (expr2).allocatable)
- return true;
-
- /* Character array functions need temporaries unless the
- character lengths are the same. */
- if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
- {
- if (expr1->ts.u.cl->length == NULL
- || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
- return true;
-
- if (expr2->ts.u.cl->length == NULL
- || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
- return true;
-
- if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
- expr2->ts.u.cl->length->value.integer) != 0)
- return true;
- }
-
- /* Check that no LHS component references appear during an array
- reference. This is needed because we do not have the means to
- span any arbitrary stride with an array descriptor. This check
- is not needed for the rhs because the function result has to be
- a complete type. */
- seen_array_ref = false;
- for (ref = expr1->ref; ref; ref = ref->next)
- {
- if (ref->type == REF_ARRAY)
- seen_array_ref= true;
- else if (ref->type == REF_COMPONENT && seen_array_ref)
- return true;
- }
-
- /* Check for a dependency. */
- if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
- expr2->value.function.esym,
- expr2->value.function.actual,
- NOT_ELEMENTAL))
- return true;
-
- /* If we have reached here with an intrinsic function, we do not
- need a temporary except in the particular case that reallocation
- on assignment is active and the lhs is allocatable and a target,
- or a pointer which may be a subref pointer. FIXME: The last
- condition can go away when we use span in the intrinsics
- directly.*/
- if (expr2->value.function.isym)
- return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target)
- || (sym->attr.pointer && sym->attr.subref_array_pointer);
-
- /* If the LHS is a dummy, we need a temporary if it is not
- INTENT(OUT). */
- if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
- return true;
-
- /* If the lhs has been host_associated, is in common, a pointer or is
- a target and the function is not using a RESULT variable, aliasing
- can occur and a temporary is needed. */
- if ((sym->attr.host_assoc
- || sym->attr.in_common
- || sym->attr.pointer
- || sym->attr.cray_pointee
- || sym->attr.target)
- && expr2->symtree != NULL
- && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
- return true;
-
- /* A PURE function can unconditionally be called without a temporary. */
- if (expr2->value.function.esym != NULL
- && expr2->value.function.esym->attr.pure)
- return false;
-
- /* Implicit_pure functions are those which could legally be declared
- to be PURE. */
- if (expr2->value.function.esym != NULL
- && expr2->value.function.esym->attr.implicit_pure)
- return false;
-
- if (!sym->attr.use_assoc
- && !sym->attr.in_common
- && !sym->attr.pointer
- && !sym->attr.target
- && !sym->attr.cray_pointee
- && expr2->value.function.esym)
- {
- /* A temporary is not needed if the function is not contained and
- the variable is local or host associated and not a pointer or
- a target. */
- if (!expr2->value.function.esym->attr.contained)
- return false;
-
- /* A temporary is not needed if the lhs has never been host
- associated and the procedure is contained. */
- else if (!sym->attr.host_assoc)
- return false;
-
- /* A temporary is not needed if the variable is local and not
- a pointer, a target or a result. */
- if (sym->ns->parent
- && expr2->value.function.esym->ns == sym->ns->parent)
- return false;
- }
-
- /* Default to temporary use. */
- return true;
-}
-
-
-/* Provide the loop info so that the lhs descriptor can be built for
- reallocatable assignments from extrinsic function calls. */
-
-static void
-realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
- gfc_loopinfo *loop)
-{
- /* Signal that the function call should not be made by
- gfc_conv_loop_setup. */
- se->ss->is_alloc_lhs = 1;
- gfc_init_loopinfo (loop);
- gfc_add_ss_to_loop (loop, *ss);
- gfc_add_ss_to_loop (loop, se->ss);
- gfc_conv_ss_startstride (loop);
- gfc_conv_loop_setup (loop, where);
- gfc_copy_loopinfo_to_se (se, loop);
- gfc_add_block_to_block (&se->pre, &loop->pre);
- gfc_add_block_to_block (&se->pre, &loop->post);
- se->ss->is_alloc_lhs = 0;
-}
-
-
-/* For assignment to a reallocatable lhs from intrinsic functions,
- replace the se.expr (ie. the result) with a temporary descriptor.
- Null the data field so that the library allocates space for the
- result. Free the data of the original descriptor after the function,
- in case it appears in an argument expression and transfer the
- result to the original descriptor. */
-
-static void
-fcncall_realloc_result (gfc_se *se, int rank)
-{
- tree desc;
- tree res_desc;
- tree tmp;
- tree offset;
- tree zero_cond;
- tree not_same_shape;
- stmtblock_t shape_block;
- int n;
-
- /* Use the allocation done by the library. Substitute the lhs
- descriptor with a copy, whose data field is nulled.*/
- desc = build_fold_indirect_ref_loc (input_location, se->expr);
- if (POINTER_TYPE_P (TREE_TYPE (desc)))
- desc = build_fold_indirect_ref_loc (input_location, desc);
-
- /* Unallocated, the descriptor does not have a dtype. */
- tmp = gfc_conv_descriptor_dtype (desc);
- gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
-
- res_desc = gfc_evaluate_now (desc, &se->pre);
- gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
- se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
-
- /* Free the lhs after the function call and copy the result data to
- the lhs descriptor. */
- tmp = gfc_conv_descriptor_data_get (desc);
- zero_cond = fold_build2_loc (input_location, EQ_EXPR,
- logical_type_node, tmp,
- build_int_cst (TREE_TYPE (tmp), 0));
- zero_cond = gfc_evaluate_now (zero_cond, &se->post);
- tmp = gfc_call_free (tmp);
- gfc_add_expr_to_block (&se->post, tmp);
-
- tmp = gfc_conv_descriptor_data_get (res_desc);
- gfc_conv_descriptor_data_set (&se->post, desc, tmp);
-
- /* Check that the shapes are the same between lhs and expression.
- The evaluation of the shape is done in 'shape_block' to avoid
- unitialized warnings from the lhs bounds. */
- not_same_shape = boolean_false_node;
- gfc_start_block (&shape_block);
- for (n = 0 ; n < rank; n++)
- {
- tree tmp1;
- tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
- tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, tmp, tmp1);
- tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, tmp, tmp1);
- tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, tmp, tmp1);
- tmp = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node, tmp,
- gfc_index_zero_node);
- tmp = gfc_evaluate_now (tmp, &shape_block);
- if (n == 0)
- not_same_shape = tmp;
- else
- not_same_shape = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- logical_type_node, tmp,
- not_same_shape);
- }
-
- /* 'zero_cond' being true is equal to lhs not being allocated or the
- shapes being different. */
- tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
- zero_cond, not_same_shape);
- gfc_add_modify (&shape_block, zero_cond, tmp);
- tmp = gfc_finish_block (&shape_block);
- tmp = build3_v (COND_EXPR, zero_cond,
- build_empty_stmt (input_location), tmp);
- gfc_add_expr_to_block (&se->post, tmp);
-
- /* Now reset the bounds returned from the function call to bounds based
- on the lhs lbounds, except where the lhs is not allocated or the shapes
- of 'variable and 'expr' are different. Set the offset accordingly. */
- offset = gfc_index_zero_node;
- for (n = 0 ; n < rank; n++)
- {
- tree lbound;
-
- lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
- lbound = fold_build3_loc (input_location, COND_EXPR,
- gfc_array_index_type, zero_cond,
- gfc_index_one_node, lbound);
- lbound = gfc_evaluate_now (lbound, &se->post);
-
- tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, tmp, lbound);
- gfc_conv_descriptor_lbound_set (&se->post, desc,
- gfc_rank_cst[n], lbound);
- gfc_conv_descriptor_ubound_set (&se->post, desc,
- gfc_rank_cst[n], tmp);
-
- /* Set stride and accumulate the offset. */
- tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
- gfc_conv_descriptor_stride_set (&se->post, desc,
- gfc_rank_cst[n], tmp);
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, lbound, tmp);
- offset = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, offset, tmp);
- offset = gfc_evaluate_now (offset, &se->post);
- }
-
- gfc_conv_descriptor_offset_set (&se->post, desc, offset);
-}
-
-
-
-/* Try to translate array(:) = func (...), where func is a transformational
- array function, without using a temporary. Returns NULL if this isn't the
- case. */
-
-static tree
-gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
-{
- gfc_se se;
- gfc_ss *ss = NULL;
- gfc_component *comp = NULL;
- gfc_loopinfo loop;
-
- if (arrayfunc_assign_needs_temporary (expr1, expr2))
- return NULL;
-
- /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
- functions. */
- comp = gfc_get_proc_ptr_comp (expr2);
-
- if (!(expr2->value.function.isym
- || (comp && comp->attr.dimension)
- || (!comp && gfc_return_by_reference (expr2->value.function.esym)
- && expr2->value.function.esym->result->attr.dimension)))
- return NULL;
-
- gfc_init_se (&se, NULL);
- gfc_start_block (&se.pre);
- se.want_pointer = 1;
-
- gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
-
- if (expr1->ts.type == BT_DERIVED
- && expr1->ts.u.derived->attr.alloc_comp)
- {
- tree tmp;
- tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr,
- expr1->rank);
- gfc_add_expr_to_block (&se.pre, tmp);
- }
-
- se.direct_byref = 1;
- se.ss = gfc_walk_expr (expr2);
- gcc_assert (se.ss != gfc_ss_terminator);
-
- /* Reallocate on assignment needs the loopinfo for extrinsic functions.
- This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
- Clearly, this cannot be done for an allocatable function result, since
- the shape of the result is unknown and, in any case, the function must
- correctly take care of the reallocation internally. For intrinsic
- calls, the array data is freed and the library takes care of allocation.
- TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
- to the library. */
- if (flag_realloc_lhs
- && gfc_is_reallocatable_lhs (expr1)
- && !gfc_expr_attr (expr1).codimension
- && !gfc_is_coindexed (expr1)
- && !(expr2->value.function.esym
- && expr2->value.function.esym->result->attr.allocatable))
- {
- realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
-
- if (!expr2->value.function.isym)
- {
- ss = gfc_walk_expr (expr1);
- gcc_assert (ss != gfc_ss_terminator);
-
- realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
- ss->is_alloc_lhs = 1;
- }
- else
- fcncall_realloc_result (&se, expr1->rank);
- }
-
- gfc_conv_function_expr (&se, expr2);
- gfc_add_block_to_block (&se.pre, &se.post);
-
- if (ss)
- gfc_cleanup_loop (&loop);
- else
- gfc_free_ss_chain (se.ss);
-
- return gfc_finish_block (&se.pre);
-}
-
-
-/* Try to efficiently translate array(:) = 0. Return NULL if this
- can't be done. */
-
-static tree
-gfc_trans_zero_assign (gfc_expr * expr)
-{
- tree dest, len, type;
- tree tmp;
- gfc_symbol *sym;
-
- sym = expr->symtree->n.sym;
- dest = gfc_get_symbol_decl (sym);
-
- type = TREE_TYPE (dest);
- if (POINTER_TYPE_P (type))
- type = TREE_TYPE (type);
- if (!GFC_ARRAY_TYPE_P (type))
- return NULL_TREE;
-
- /* Determine the length of the array. */
- len = GFC_TYPE_ARRAY_SIZE (type);
- if (!len || TREE_CODE (len) != INTEGER_CST)
- return NULL_TREE;
-
- tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
- len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
- fold_convert (gfc_array_index_type, tmp));
-
- /* If we are zeroing a local array avoid taking its address by emitting
- a = {} instead. */
- if (!POINTER_TYPE_P (TREE_TYPE (dest)))
- return build2_loc (input_location, MODIFY_EXPR, void_type_node,
- dest, build_constructor (TREE_TYPE (dest),
- NULL));
-
- /* Convert arguments to the correct types. */
- dest = fold_convert (pvoid_type_node, dest);
- len = fold_convert (size_type_node, len);
-
- /* Construct call to __builtin_memset. */
- tmp = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_MEMSET),
- 3, dest, integer_zero_node, len);
- return fold_convert (void_type_node, tmp);
-}
-
-
-/* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
- that constructs the call to __builtin_memcpy. */
-
-tree
-gfc_build_memcpy_call (tree dst, tree src, tree len)
-{
- tree tmp;
-
- /* Convert arguments to the correct types. */
- if (!POINTER_TYPE_P (TREE_TYPE (dst)))
- dst = gfc_build_addr_expr (pvoid_type_node, dst);
- else
- dst = fold_convert (pvoid_type_node, dst);
-
- if (!POINTER_TYPE_P (TREE_TYPE (src)))
- src = gfc_build_addr_expr (pvoid_type_node, src);
- else
- src = fold_convert (pvoid_type_node, src);
-
- len = fold_convert (size_type_node, len);
-
- /* Construct call to __builtin_memcpy. */
- tmp = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_MEMCPY),
- 3, dst, src, len);
- return fold_convert (void_type_node, tmp);
-}
-
-
-/* Try to efficiently translate dst(:) = src(:). Return NULL if this
- can't be done. EXPR1 is the destination/lhs and EXPR2 is the
- source/rhs, both are gfc_full_array_ref_p which have been checked for
- dependencies. */
-
-static tree
-gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
-{
- tree dst, dlen, dtype;
- tree src, slen, stype;
- tree tmp;
-
- dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
- src = gfc_get_symbol_decl (expr2->symtree->n.sym);
-
- dtype = TREE_TYPE (dst);
- if (POINTER_TYPE_P (dtype))
- dtype = TREE_TYPE (dtype);
- stype = TREE_TYPE (src);
- if (POINTER_TYPE_P (stype))
- stype = TREE_TYPE (stype);
-
- if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
- return NULL_TREE;
-
- /* Determine the lengths of the arrays. */
- dlen = GFC_TYPE_ARRAY_SIZE (dtype);
- if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
- return NULL_TREE;
- tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
- dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- dlen, fold_convert (gfc_array_index_type, tmp));
-
- slen = GFC_TYPE_ARRAY_SIZE (stype);
- if (!slen || TREE_CODE (slen) != INTEGER_CST)
- return NULL_TREE;
- tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
- slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- slen, fold_convert (gfc_array_index_type, tmp));
-
- /* Sanity check that they are the same. This should always be
- the case, as we should already have checked for conformance. */
- if (!tree_int_cst_equal (slen, dlen))
- return NULL_TREE;
-
- return gfc_build_memcpy_call (dst, src, dlen);
-}
-
-
-/* Try to efficiently translate array(:) = (/ ... /). Return NULL if
- this can't be done. EXPR1 is the destination/lhs for which
- gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
-
-static tree
-gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
-{
- unsigned HOST_WIDE_INT nelem;
- tree dst, dtype;
- tree src, stype;
- tree len;
- tree tmp;
-
- nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
- if (nelem == 0)
- return NULL_TREE;
-
- dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
- dtype = TREE_TYPE (dst);
- if (POINTER_TYPE_P (dtype))
- dtype = TREE_TYPE (dtype);
- if (!GFC_ARRAY_TYPE_P (dtype))
- return NULL_TREE;
-
- /* Determine the lengths of the array. */
- len = GFC_TYPE_ARRAY_SIZE (dtype);
- if (!len || TREE_CODE (len) != INTEGER_CST)
- return NULL_TREE;
-
- /* Confirm that the constructor is the same size. */
- if (compare_tree_int (len, nelem) != 0)
- return NULL_TREE;
-
- tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
- len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
- fold_convert (gfc_array_index_type, tmp));
-
- stype = gfc_typenode_for_spec (&expr2->ts);
- src = gfc_build_constant_array_constructor (expr2, stype);
-
- return gfc_build_memcpy_call (dst, src, len);
-}
-
-
-/* Tells whether the expression is to be treated as a variable reference. */
-
-bool
-gfc_expr_is_variable (gfc_expr *expr)
-{
- gfc_expr *arg;
- gfc_component *comp;
- gfc_symbol *func_ifc;
-
- if (expr->expr_type == EXPR_VARIABLE)
- return true;
-
- arg = gfc_get_noncopying_intrinsic_argument (expr);
- if (arg)
- {
- gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
- return gfc_expr_is_variable (arg);
- }
-
- /* A data-pointer-returning function should be considered as a variable
- too. */
- if (expr->expr_type == EXPR_FUNCTION
- && expr->ref == NULL)
- {
- if (expr->value.function.isym != NULL)
- return false;
-
- if (expr->value.function.esym != NULL)
- {
- func_ifc = expr->value.function.esym;
- goto found_ifc;
- }
- gcc_assert (expr->symtree);
- func_ifc = expr->symtree->n.sym;
- goto found_ifc;
- }
-
- comp = gfc_get_proc_ptr_comp (expr);
- if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
- && comp)
- {
- func_ifc = comp->ts.interface;
- goto found_ifc;
- }
-
- if (expr->expr_type == EXPR_COMPCALL)
- {
- gcc_assert (!expr->value.compcall.tbp->is_generic);
- func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
- goto found_ifc;
- }
-
- return false;
-
-found_ifc:
- gcc_assert (func_ifc->attr.function
- && func_ifc->result != NULL);
- return func_ifc->result->attr.pointer;
-}
-
-
-/* Is the lhs OK for automatic reallocation? */
-
-static bool
-is_scalar_reallocatable_lhs (gfc_expr *expr)
-{
- gfc_ref * ref;
-
- /* An allocatable variable with no reference. */
- if (expr->symtree->n.sym->attr.allocatable
- && !expr->ref)
- return true;
-
- /* All that can be left are allocatable components. However, we do
- not check for allocatable components here because the expression
- could be an allocatable component of a pointer component. */
- if (expr->symtree->n.sym->ts.type != BT_DERIVED
- && expr->symtree->n.sym->ts.type != BT_CLASS)
- return false;
-
- /* Find an allocatable component ref last. */
- for (ref = expr->ref; ref; ref = ref->next)
- if (ref->type == REF_COMPONENT
- && !ref->next
- && ref->u.c.component->attr.allocatable)
- return true;
-
- return false;
-}
-
-
-/* Allocate or reallocate scalar lhs, as necessary. */
-
-static void
-alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
- tree string_length,
- gfc_expr *expr1,
- gfc_expr *expr2)
-
-{
- tree cond;
- tree tmp;
- tree size;
- tree size_in_bytes;
- tree jump_label1;
- tree jump_label2;
- gfc_se lse;
- gfc_ref *ref;
-
- if (!expr1 || expr1->rank)
- return;
-
- if (!expr2 || expr2->rank)
- return;
-
- for (ref = expr1->ref; ref; ref = ref->next)
- if (ref->type == REF_SUBSTRING)
- return;
-
- realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
-
- /* Since this is a scalar lhs, we can afford to do this. That is,
- there is no risk of side effects being repeated. */
- gfc_init_se (&lse, NULL);
- lse.want_pointer = 1;
- gfc_conv_expr (&lse, expr1);
-
- jump_label1 = gfc_build_label_decl (NULL_TREE);
- jump_label2 = gfc_build_label_decl (NULL_TREE);
-
- /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
- tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
- cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
- lse.expr, tmp);
- tmp = build3_v (COND_EXPR, cond,
- build1_v (GOTO_EXPR, jump_label1),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (block, tmp);
-
- if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
- {
- /* Use the rhs string length and the lhs element size. */
- size = string_length;
- tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
- tmp = TYPE_SIZE_UNIT (tmp);
- size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
- TREE_TYPE (tmp), tmp,
- fold_convert (TREE_TYPE (tmp), size));
- }
- else
- {
- /* Otherwise use the length in bytes of the rhs. */
- size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
- size_in_bytes = size;
- }
-
- size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
- size_in_bytes, size_one_node);
-
- if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
- {
- tree caf_decl, token;
- gfc_se caf_se;
- symbol_attribute attr;
-
- gfc_clear_attr (&attr);
- gfc_init_se (&caf_se, NULL);
-
- caf_decl = gfc_get_tree_for_caf_expr (expr1);
- gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
- NULL);
- gfc_add_block_to_block (block, &caf_se.pre);
- gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
- gfc_build_addr_expr (NULL_TREE, token),
- NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
- expr1, 1);
- }
- else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
- {
- tmp = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_CALLOC),
- 2, build_one_cst (size_type_node),
- size_in_bytes);
- tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
- gfc_add_modify (block, lse.expr, tmp);
- }
- else
- {
- tmp = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_MALLOC),
- 1, size_in_bytes);
- tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
- gfc_add_modify (block, lse.expr, tmp);
- }
-
- if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
- {
- /* Deferred characters need checking for lhs and rhs string
- length. Other deferred parameter variables will have to
- come here too. */
- tmp = build1_v (GOTO_EXPR, jump_label2);
- gfc_add_expr_to_block (block, tmp);
- }
- tmp = build1_v (LABEL_EXPR, jump_label1);
- gfc_add_expr_to_block (block, tmp);
-
- /* For a deferred length character, reallocate if lengths of lhs and
- rhs are different. */
- if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
- {
- cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
- lse.string_length,
- fold_convert (TREE_TYPE (lse.string_length),
- size));
- /* Jump past the realloc if the lengths are the same. */
- tmp = build3_v (COND_EXPR, cond,
- build1_v (GOTO_EXPR, jump_label2),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (block, tmp);
- tmp = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_REALLOC),
- 2, fold_convert (pvoid_type_node, lse.expr),
- size_in_bytes);
- tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
- gfc_add_modify (block, lse.expr, tmp);
- tmp = build1_v (LABEL_EXPR, jump_label2);
- gfc_add_expr_to_block (block, tmp);
-
- /* Update the lhs character length. */
- size = string_length;
- gfc_add_modify (block, lse.string_length,
- fold_convert (TREE_TYPE (lse.string_length), size));
- }
-}
-
-/* Check for assignments of the type
-
- a = a + 4
-
- to make sure we do not check for reallocation unneccessarily. */
-
-
-static bool
-is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
-{
- gfc_actual_arglist *a;
- gfc_expr *e1, *e2;
-
- switch (expr2->expr_type)
- {
- case EXPR_VARIABLE:
- return gfc_dep_compare_expr (expr1, expr2) == 0;
-
- case EXPR_FUNCTION:
- if (expr2->value.function.esym
- && expr2->value.function.esym->attr.elemental)
- {
- for (a = expr2->value.function.actual; a != NULL; a = a->next)
- {
- e1 = a->expr;
- if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
- return false;
- }
- return true;
- }
- else if (expr2->value.function.isym
- && expr2->value.function.isym->elemental)
- {
- for (a = expr2->value.function.actual; a != NULL; a = a->next)
- {
- e1 = a->expr;
- if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
- return false;
- }
- return true;
- }
-
- break;
-
- case EXPR_OP:
- switch (expr2->value.op.op)
- {
- case INTRINSIC_NOT:
- case INTRINSIC_UPLUS:
- case INTRINSIC_UMINUS:
- case INTRINSIC_PARENTHESES:
- return is_runtime_conformable (expr1, expr2->value.op.op1);
-
- case INTRINSIC_PLUS:
- case INTRINSIC_MINUS:
- case INTRINSIC_TIMES:
- case INTRINSIC_DIVIDE:
- case INTRINSIC_POWER:
- case INTRINSIC_AND:
- case INTRINSIC_OR:
- case INTRINSIC_EQV:
- case INTRINSIC_NEQV:
- case INTRINSIC_EQ:
- case INTRINSIC_NE:
- case INTRINSIC_GT:
- case INTRINSIC_GE:
- case INTRINSIC_LT:
- case INTRINSIC_LE:
- case INTRINSIC_EQ_OS:
- case INTRINSIC_NE_OS:
- case INTRINSIC_GT_OS:
- case INTRINSIC_GE_OS:
- case INTRINSIC_LT_OS:
- case INTRINSIC_LE_OS:
-
- e1 = expr2->value.op.op1;
- e2 = expr2->value.op.op2;
-
- if (e1->rank == 0 && e2->rank > 0)
- return is_runtime_conformable (expr1, e2);
- else if (e1->rank > 0 && e2->rank == 0)
- return is_runtime_conformable (expr1, e1);
- else if (e1->rank > 0 && e2->rank > 0)
- return is_runtime_conformable (expr1, e1)
- && is_runtime_conformable (expr1, e2);
- break;
-
- default:
- break;
-
- }
-
- break;
-
- default:
- break;
- }
- return false;
-}
-
-
-static tree
-trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
- gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
- bool class_realloc)
-{
- tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr;
- vec<tree, va_gc> *args = NULL;
-
- /* Store the old vptr so that dynamic types can be compared for
- reallocation to occur or not. */
- if (class_realloc)
- {
- tmp = lse->expr;
- if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
- tmp = gfc_get_class_from_expr (tmp);
- }
-
- vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
- &from_len);
-
- /* Generate (re)allocation of the lhs. */
- if (class_realloc)
- {
- stmtblock_t alloc, re_alloc;
- tree class_han, re, size;
-
- if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
- old_vptr = gfc_evaluate_now (gfc_class_vptr_get (tmp), block);
- else
- old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
-
- size = gfc_vptr_size_get (vptr);
- class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
- ? gfc_class_data_get (lse->expr) : lse->expr;
-
- /* Allocate block. */
- gfc_init_block (&alloc);
- gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE);
-
- /* Reallocate if dynamic types are different. */
- gfc_init_block (&re_alloc);
- re = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_REALLOC), 2,
- fold_convert (pvoid_type_node, class_han),
- size);
- tmp = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node, vptr, old_vptr);
- re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
- tmp, re, build_empty_stmt (input_location));
- gfc_add_expr_to_block (&re_alloc, re);
-
- /* Allocate if _data is NULL, reallocate otherwise. */
- tmp = fold_build2_loc (input_location, EQ_EXPR,
- logical_type_node, class_han,
- build_int_cst (prvoid_type_node, 0));
- tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
- gfc_unlikely (tmp,
- PRED_FORTRAN_FAIL_ALLOC),
- gfc_finish_block (&alloc),
- gfc_finish_block (&re_alloc));
- gfc_add_expr_to_block (&lse->pre, tmp);
- }
-
- fcn = gfc_vptr_copy_get (vptr);
-
- tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
- ? gfc_class_data_get (rse->expr) : rse->expr;
- if (use_vptr_copy)
- {
- if (!POINTER_TYPE_P (TREE_TYPE (tmp))
- || INDIRECT_REF_P (tmp)
- || (rhs->ts.type == BT_DERIVED
- && rhs->ts.u.derived->attr.unlimited_polymorphic
- && !rhs->ts.u.derived->attr.pointer
- && !rhs->ts.u.derived->attr.allocatable)
- || (UNLIMITED_POLY (rhs)
- && !CLASS_DATA (rhs)->attr.pointer
- && !CLASS_DATA (rhs)->attr.allocatable))
- vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
- else
- vec_safe_push (args, tmp);
- tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
- ? gfc_class_data_get (lse->expr) : lse->expr;
- if (!POINTER_TYPE_P (TREE_TYPE (tmp))
- || INDIRECT_REF_P (tmp)
- || (lhs->ts.type == BT_DERIVED
- && lhs->ts.u.derived->attr.unlimited_polymorphic
- && !lhs->ts.u.derived->attr.pointer
- && !lhs->ts.u.derived->attr.allocatable)
- || (UNLIMITED_POLY (lhs)
- && !CLASS_DATA (lhs)->attr.pointer
- && !CLASS_DATA (lhs)->attr.allocatable))
- vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
- else
- vec_safe_push (args, tmp);
-
- stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
-
- if (to_len != NULL_TREE && !integer_zerop (from_len))
- {
- tree extcopy;
- vec_safe_push (args, from_len);
- vec_safe_push (args, to_len);
- extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
-
- tmp = fold_build2_loc (input_location, GT_EXPR,
- logical_type_node, from_len,
- build_zero_cst (TREE_TYPE (from_len)));
- return fold_build3_loc (input_location, COND_EXPR,
- void_type_node, tmp,
- extcopy, stdcopy);
- }
- else
- return stdcopy;
- }
- else
- {
- tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
- ? gfc_class_data_get (lse->expr) : lse->expr;
- stmtblock_t tblock;
- gfc_init_block (&tblock);
- if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
- if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
- rhst = gfc_build_addr_expr (NULL_TREE, rhst);
- /* When coming from a ptr_copy lhs and rhs are swapped. */
- gfc_add_modify_loc (input_location, &tblock, rhst,
- fold_convert (TREE_TYPE (rhst), tmp));
- return gfc_finish_block (&tblock);
- }
-}
-
-/* Subroutine of gfc_trans_assignment that actually scalarizes the
- assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
- init_flag indicates initialization expressions and dealloc that no
- deallocate prior assignment is needed (if in doubt, set true).
- When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
- routine instead of a pointer assignment. Alias resolution is only done,
- when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
- where it is known, that newly allocated memory on the lhs can never be
- an alias of the rhs. */
-
-static tree
-gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
- bool dealloc, bool use_vptr_copy, bool may_alias)
-{
- gfc_se lse;
- gfc_se rse;
- gfc_ss *lss;
- gfc_ss *lss_section;
- gfc_ss *rss;
- gfc_loopinfo loop;
- tree tmp;
- stmtblock_t block;
- stmtblock_t body;
- bool l_is_temp;
- bool scalar_to_array;
- tree string_length;
- int n;
- bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
- symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
- bool is_poly_assign;
- bool realloc_flag;
-
- /* Assignment of the form lhs = rhs. */
- gfc_start_block (&block);
-
- gfc_init_se (&lse, NULL);
- gfc_init_se (&rse, NULL);
-
- /* Walk the lhs. */
- lss = gfc_walk_expr (expr1);
- if (gfc_is_reallocatable_lhs (expr1))
- {
- lss->no_bounds_check = 1;
- if (!(expr2->expr_type == EXPR_FUNCTION
- && expr2->value.function.isym != NULL
- && !(expr2->value.function.isym->elemental
- || expr2->value.function.isym->conversion)))
- lss->is_alloc_lhs = 1;
- }
- else
- lss->no_bounds_check = expr1->no_bounds_check;
-
- rss = NULL;
-
- if ((expr1->ts.type == BT_DERIVED)
- && (gfc_is_class_array_function (expr2)
- || gfc_is_alloc_class_scalar_function (expr2)))
- expr2->must_finalize = 1;
-
- /* Checking whether a class assignment is desired is quite complicated and
- needed at two locations, so do it once only before the information is
- needed. */
- lhs_attr = gfc_expr_attr (expr1);
- is_poly_assign = (use_vptr_copy || lhs_attr.pointer
- || (lhs_attr.allocatable && !lhs_attr.dimension))
- && (expr1->ts.type == BT_CLASS
- || gfc_is_class_array_ref (expr1, NULL)
- || gfc_is_class_scalar_expr (expr1)
- || gfc_is_class_array_ref (expr2, NULL)
- || gfc_is_class_scalar_expr (expr2))
- && lhs_attr.flavor != FL_PROCEDURE;
-
- realloc_flag = flag_realloc_lhs
- && gfc_is_reallocatable_lhs (expr1)
- && expr2->rank
- && !is_runtime_conformable (expr1, expr2);
-
- /* Only analyze the expressions for coarray properties, when in coarray-lib
- mode. */
- if (flag_coarray == GFC_FCOARRAY_LIB)
- {
- lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
- rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
- }
-
- if (lss != gfc_ss_terminator)
- {
- /* The assignment needs scalarization. */
- lss_section = lss;
-
- /* Find a non-scalar SS from the lhs. */
- while (lss_section != gfc_ss_terminator
- && lss_section->info->type != GFC_SS_SECTION)
- lss_section = lss_section->next;
-
- gcc_assert (lss_section != gfc_ss_terminator);
-
- /* Initialize the scalarizer. */
- gfc_init_loopinfo (&loop);
-
- /* Walk the rhs. */
- rss = gfc_walk_expr (expr2);
- if (rss == gfc_ss_terminator)
- /* The rhs is scalar. Add a ss for the expression. */
- rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
- /* When doing a class assign, then the handle to the rhs needs to be a
- pointer to allow for polymorphism. */
- if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
- rss->info->type = GFC_SS_REFERENCE;
-
- rss->no_bounds_check = expr2->no_bounds_check;
- /* Associate the SS with the loop. */
- gfc_add_ss_to_loop (&loop, lss);
- gfc_add_ss_to_loop (&loop, rss);
-
- /* Calculate the bounds of the scalarization. */
- gfc_conv_ss_startstride (&loop);
- /* Enable loop reversal. */
- for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
- loop.reverse[n] = GFC_ENABLE_REVERSE;
- /* Resolve any data dependencies in the statement. */
- if (may_alias)
- gfc_conv_resolve_dependencies (&loop, lss, rss);
- /* Setup the scalarizing loops. */
- gfc_conv_loop_setup (&loop, &expr2->where);
-
- /* Setup the gfc_se structures. */
- gfc_copy_loopinfo_to_se (&lse, &loop);
- gfc_copy_loopinfo_to_se (&rse, &loop);
-
- rse.ss = rss;
- gfc_mark_ss_chain_used (rss, 1);
- if (loop.temp_ss == NULL)
- {
- lse.ss = lss;
- gfc_mark_ss_chain_used (lss, 1);
- }
- else
- {
- lse.ss = loop.temp_ss;
- gfc_mark_ss_chain_used (lss, 3);
- gfc_mark_ss_chain_used (loop.temp_ss, 3);
- }
-
- /* Allow the scalarizer to workshare array assignments. */
- if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
- == OMPWS_WORKSHARE_FLAG
- && loop.temp_ss == NULL)
- {
- maybe_workshare = true;
- ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
- }
-
- /* Start the scalarized loop body. */
- gfc_start_scalarized_body (&loop, &body);
- }
- else
- gfc_init_block (&body);
-
- l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
-
- /* Translate the expression. */
- rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag
- && lhs_caf_attr.codimension;
- gfc_conv_expr (&rse, expr2);
-
- /* Deal with the case of a scalar class function assigned to a derived type. */
- if (gfc_is_alloc_class_scalar_function (expr2)
- && expr1->ts.type == BT_DERIVED)
- {
- rse.expr = gfc_class_data_get (rse.expr);
- rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
- }
-
- /* Stabilize a string length for temporaries. */
- if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
- && !(VAR_P (rse.string_length)
- || TREE_CODE (rse.string_length) == PARM_DECL
- || TREE_CODE (rse.string_length) == INDIRECT_REF))
- string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
- else if (expr2->ts.type == BT_CHARACTER)
- {
- if (expr1->ts.deferred
- && gfc_expr_attr (expr1).allocatable
- && gfc_check_dependency (expr1, expr2, true))
- rse.string_length =
- gfc_evaluate_now_function_scope (rse.string_length, &rse.pre);
- string_length = rse.string_length;
- }
- else
- string_length = NULL_TREE;
-
- if (l_is_temp)
- {
- gfc_conv_tmp_array_ref (&lse);
- if (expr2->ts.type == BT_CHARACTER)
- lse.string_length = string_length;
- }
- else
- {
- gfc_conv_expr (&lse, expr1);
- if (gfc_option.rtcheck & GFC_RTCHECK_MEM
- && !init_flag
- && gfc_expr_attr (expr1).allocatable
- && expr1->rank
- && !expr2->rank)
- {
- tree cond;
- const char* msg;
-
- tmp = INDIRECT_REF_P (lse.expr)
- ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
- STRIP_NOPS (tmp);
-
- /* We should only get array references here. */
- gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
- || TREE_CODE (tmp) == ARRAY_REF);
-
- /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
- or the array itself(ARRAY_REF). */
- tmp = TREE_OPERAND (tmp, 0);
-
- /* Provide the address of the array. */
- if (TREE_CODE (lse.expr) == ARRAY_REF)
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
-
- cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
- tmp, build_int_cst (TREE_TYPE (tmp), 0));
- msg = _("Assignment of scalar to unallocated array");
- gfc_trans_runtime_check (true, false, cond, &loop.pre,
- &expr1->where, msg);
- }
-
- /* Deallocate the lhs parameterized components if required. */
- if (dealloc && expr2->expr_type == EXPR_FUNCTION
- && !expr1->symtree->n.sym->attr.associate_var)
- {
- if (expr1->ts.type == BT_DERIVED
- && expr1->ts.u.derived
- && expr1->ts.u.derived->attr.pdt_type)
- {
- tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, lse.expr,
- expr1->rank);
- gfc_add_expr_to_block (&lse.pre, tmp);
- }
- else if (expr1->ts.type == BT_CLASS
- && CLASS_DATA (expr1)->ts.u.derived
- && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)
- {
- tmp = gfc_class_data_get (lse.expr);
- tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
- tmp, expr1->rank);
- gfc_add_expr_to_block (&lse.pre, tmp);
- }
- }
- }
-
- /* Assignments of scalar derived types with allocatable components
- to arrays must be done with a deep copy and the rhs temporary
- must have its components deallocated afterwards. */
- scalar_to_array = (expr2->ts.type == BT_DERIVED
- && expr2->ts.u.derived->attr.alloc_comp
- && !gfc_expr_is_variable (expr2)
- && expr1->rank && !expr2->rank);
- scalar_to_array |= (expr1->ts.type == BT_DERIVED
- && expr1->rank
- && expr1->ts.u.derived->attr.alloc_comp
- && gfc_is_alloc_class_scalar_function (expr2));
- if (scalar_to_array && dealloc)
- {
- tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
- gfc_prepend_expr_to_block (&loop.post, tmp);
- }
-
- /* When assigning a character function result to a deferred-length variable,
- the function call must happen before the (re)allocation of the lhs -
- otherwise the character length of the result is not known.
- NOTE 1: This relies on having the exact dependence of the length type
- parameter available to the caller; gfortran saves it in the .mod files.
- NOTE 2: Vector array references generate an index temporary that must
- not go outside the loop. Otherwise, variables should not generate
- a pre block.
- NOTE 3: The concatenation operation generates a temporary pointer,
- whose allocation must go to the innermost loop.
- NOTE 4: Elemental functions may generate a temporary, too. */
- if (flag_realloc_lhs
- && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
- && !(lss != gfc_ss_terminator
- && rss != gfc_ss_terminator
- && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
- || (expr2->expr_type == EXPR_FUNCTION
- && expr2->value.function.esym != NULL
- && expr2->value.function.esym->attr.elemental)
- || (expr2->expr_type == EXPR_FUNCTION
- && expr2->value.function.isym != NULL
- && expr2->value.function.isym->elemental)
- || (expr2->expr_type == EXPR_OP
- && expr2->value.op.op == INTRINSIC_CONCAT))))
- gfc_add_block_to_block (&block, &rse.pre);
-
- /* Nullify the allocatable components corresponding to those of the lhs
- derived type, so that the finalization of the function result does not
- affect the lhs of the assignment. Prepend is used to ensure that the
- nullification occurs before the call to the finalizer. In the case of
- a scalar to array assignment, this is done in gfc_trans_scalar_assign
- as part of the deep copy. */
- if (!scalar_to_array && expr1->ts.type == BT_DERIVED
- && (gfc_is_class_array_function (expr2)
- || gfc_is_alloc_class_scalar_function (expr2)))
- {
- tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
- gfc_prepend_expr_to_block (&rse.post, tmp);
- if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
- gfc_add_block_to_block (&loop.post, &rse.post);
- }
-
- tmp = NULL_TREE;
-
- if (is_poly_assign)
- {
- tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
- use_vptr_copy || (lhs_attr.allocatable
- && !lhs_attr.dimension),
- !realloc_flag && flag_realloc_lhs
- && !lhs_attr.pointer);
- if (expr2->expr_type == EXPR_FUNCTION
- && expr2->ts.type == BT_DERIVED
- && expr2->ts.u.derived->attr.alloc_comp)
- {
- tree tmp2 = gfc_deallocate_alloc_comp (expr2->ts.u.derived,
- rse.expr, expr2->rank);
- if (lss == gfc_ss_terminator)
- gfc_add_expr_to_block (&rse.post, tmp2);
- else
- gfc_add_expr_to_block (&loop.post, tmp2);
- }
- }
- else if (flag_coarray == GFC_FCOARRAY_LIB
- && lhs_caf_attr.codimension && rhs_caf_attr.codimension
- && ((lhs_caf_attr.allocatable && lhs_refs_comp)
- || (rhs_caf_attr.allocatable && rhs_refs_comp)))
- {
- /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
- allocatable component, because those need to be accessed via the
- caf-runtime. No need to check for coindexes here, because resolve
- has rewritten those already. */
- gfc_code code;
- gfc_actual_arglist a1, a2;
- /* Clear the structures to prevent accessing garbage. */
- memset (&code, '\0', sizeof (gfc_code));
- memset (&a1, '\0', sizeof (gfc_actual_arglist));
- memset (&a2, '\0', sizeof (gfc_actual_arglist));
- a1.expr = expr1;
- a1.next = &a2;
- a2.expr = expr2;
- a2.next = NULL;
- code.ext.actual = &a1;
- code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
- tmp = gfc_conv_intrinsic_subroutine (&code);
- }
- else if (!is_poly_assign && expr2->must_finalize
- && expr1->ts.type == BT_CLASS
- && expr2->ts.type == BT_CLASS)
- {
- /* This case comes about when the scalarizer provides array element
- references. Use the vptr copy function, since this does a deep
- copy of allocatable components, without which the finalizer call
- will deallocate the components. */
- tmp = gfc_get_vptr_from_expr (rse.expr);
- if (tmp != NULL_TREE)
- {
- tree fcn = gfc_vptr_copy_get (tmp);
- if (POINTER_TYPE_P (TREE_TYPE (fcn)))
- fcn = build_fold_indirect_ref_loc (input_location, fcn);
- tmp = build_call_expr_loc (input_location,
- fcn, 2,
- gfc_build_addr_expr (NULL, rse.expr),
- gfc_build_addr_expr (NULL, lse.expr));
- }
- }
-
- /* If nothing else works, do it the old fashioned way! */
- if (tmp == NULL_TREE)
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
- gfc_expr_is_variable (expr2)
- || scalar_to_array
- || expr2->expr_type == EXPR_ARRAY,
- !(l_is_temp || init_flag) && dealloc,
- expr1->symtree->n.sym->attr.codimension);
-
- /* Add the pre blocks to the body. */
- gfc_add_block_to_block (&body, &rse.pre);
- gfc_add_block_to_block (&body, &lse.pre);
- gfc_add_expr_to_block (&body, tmp);
- /* Add the post blocks to the body. */
- gfc_add_block_to_block (&body, &rse.post);
- gfc_add_block_to_block (&body, &lse.post);
-
- if (lss == gfc_ss_terminator)
- {
- /* F2003: Add the code for reallocation on assignment. */
- if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
- && !is_poly_assign)
- alloc_scalar_allocatable_for_assignment (&block, string_length,
- expr1, expr2);
-
- /* Use the scalar assignment as is. */
- gfc_add_block_to_block (&block, &body);
- }
- else
- {
- gcc_assert (lse.ss == gfc_ss_terminator
- && rse.ss == gfc_ss_terminator);
-
- if (l_is_temp)
- {
- gfc_trans_scalarized_loop_boundary (&loop, &body);
-
- /* We need to copy the temporary to the actual lhs. */
- gfc_init_se (&lse, NULL);
- gfc_init_se (&rse, NULL);
- gfc_copy_loopinfo_to_se (&lse, &loop);
- gfc_copy_loopinfo_to_se (&rse, &loop);
-
- rse.ss = loop.temp_ss;
- lse.ss = lss;
-
- gfc_conv_tmp_array_ref (&rse);
- gfc_conv_expr (&lse, expr1);
-
- gcc_assert (lse.ss == gfc_ss_terminator
- && rse.ss == gfc_ss_terminator);
-
- if (expr2->ts.type == BT_CHARACTER)
- rse.string_length = string_length;
-
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
- false, dealloc);
- gfc_add_expr_to_block (&body, tmp);
- }
-
- /* F2003: Allocate or reallocate lhs of allocatable array. */
- if (realloc_flag)
- {
- realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
- ompws_flags &= ~OMPWS_SCALARIZER_WS;
- tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
- if (tmp != NULL_TREE)
- gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
- }
-
- if (maybe_workshare)
- ompws_flags &= ~OMPWS_SCALARIZER_BODY;
-
- /* Generate the copying loops. */
- gfc_trans_scalarizing_loops (&loop, &body);
-
- /* Wrap the whole thing up. */
- gfc_add_block_to_block (&block, &loop.pre);
- gfc_add_block_to_block (&block, &loop.post);
-
- gfc_cleanup_loop (&loop);
- }
-
- return gfc_finish_block (&block);
-}
-
-
-/* Check whether EXPR is a copyable array. */
-
-static bool
-copyable_array_p (gfc_expr * expr)
-{
- if (expr->expr_type != EXPR_VARIABLE)
- return false;
-
- /* First check it's an array. */
- if (expr->rank < 1 || !expr->ref || expr->ref->next)
- return false;
-
- if (!gfc_full_array_ref_p (expr->ref, NULL))
- return false;
-
- /* Next check that it's of a simple enough type. */
- switch (expr->ts.type)
- {
- case BT_INTEGER:
- case BT_REAL:
- case BT_COMPLEX:
- case BT_LOGICAL:
- return true;
-
- case BT_CHARACTER:
- return false;
-
- case_bt_struct:
- return !expr->ts.u.derived->attr.alloc_comp;
-
- default:
- break;
- }
-
- return false;
-}
-
-/* Translate an assignment. */
-
-tree
-gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
- bool dealloc, bool use_vptr_copy, bool may_alias)
-{
- tree tmp;
-
- /* Special case a single function returning an array. */
- if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
- {
- tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
- if (tmp)
- return tmp;
- }
-
- /* Special case assigning an array to zero. */
- if (copyable_array_p (expr1)
- && is_zero_initializer_p (expr2))
- {
- tmp = gfc_trans_zero_assign (expr1);
- if (tmp)
- return tmp;
- }
-
- /* Special case copying one array to another. */
- if (copyable_array_p (expr1)
- && copyable_array_p (expr2)
- && gfc_compare_types (&expr1->ts, &expr2->ts)
- && !gfc_check_dependency (expr1, expr2, 0))
- {
- tmp = gfc_trans_array_copy (expr1, expr2);
- if (tmp)
- return tmp;
- }
-
- /* Special case initializing an array from a constant array constructor. */
- if (copyable_array_p (expr1)
- && expr2->expr_type == EXPR_ARRAY
- && gfc_compare_types (&expr1->ts, &expr2->ts))
- {
- tmp = gfc_trans_array_constructor_copy (expr1, expr2);
- if (tmp)
- return tmp;
- }
-
- if (UNLIMITED_POLY (expr1) && expr1->rank)
- use_vptr_copy = true;
-
- /* Fallback to the scalarizer to generate explicit loops. */
- return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
- use_vptr_copy, may_alias);
-}
-
-tree
-gfc_trans_init_assign (gfc_code * code)
-{
- return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
-}
-
-tree
-gfc_trans_assign (gfc_code * code)
-{
- return gfc_trans_assignment (code->expr1, code->expr2, false, true);
-}
-
-/* Generate a simple loop for internal use of the form
- for (var = begin; var <cond> end; var += step)
- body; */
-void
-gfc_simple_for_loop (stmtblock_t *block, tree var, tree begin, tree end,
- enum tree_code cond, tree step, tree body)
-{
- tree tmp;
-
- /* var = begin. */
- gfc_add_modify (block, var, begin);
-
- /* Loop: for (var = begin; var <cond> end; var += step). */
- tree label_loop = gfc_build_label_decl (NULL_TREE);
- tree label_cond = gfc_build_label_decl (NULL_TREE);
- TREE_USED (label_loop) = 1;
- TREE_USED (label_cond) = 1;
-
- gfc_add_expr_to_block (block, build1_v (GOTO_EXPR, label_cond));
- gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_loop));
-
- /* Loop body. */
- gfc_add_expr_to_block (block, body);
-
- /* End of loop body. */
- tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var, step);
- gfc_add_modify (block, var, tmp);
- gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_cond));
- tmp = fold_build2_loc (input_location, cond, boolean_type_node, var, end);
- tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_loop),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (block, tmp);
-}
generated by cgit v1.1 at 2025-05-22 12:19:30 +0000